diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml
index 0c1a8967b8685fa24d4a55754bfb6ea957a78adc..8353626dd807af9ccf4c53217441e86cf8c765f2 100644
--- a/.gitlab-ci.yml
+++ b/.gitlab-ci.yml
@@ -42,10 +42,13 @@ stages:
# to be implemented ...
# pkkprime stages
- build_pkkprime
- # run and verift stages not defined yet
+ # run and verify stages not defined yet
# rhoq stages
- build_rhoq
- # run and verift stages not defined yet
+ # run and verify stages not defined yet
+ # kkrnano stages
+ - build_kkrnano
+ - run_kkrnano
###############################################################################
@@ -81,12 +84,14 @@ include:
- tests/gitlab-ci/build_pkkprime.yml
- tests/gitlab-ci/build_voronoi.yml
- tests/gitlab-ci/build_rhoq.yml
+ - tests/gitlab-ci/build_kkrnano.yml
### 2. run tests ###
- tests/gitlab-ci/run_kkrhost.yml
- tests/gitlab-ci/run_kkrimp.yml
#- tests/gitlab-ci/run_kkrsusc.yml
#- tests/gitlab-ci/run_pkkprime.yml
- tests/gitlab-ci/run_voronoi.yml
+ - tests/gitlab-ci/run_kkrnano.yml
### 3. verify results ###
- tests/gitlab-ci/verify_kkrhost.yml
- tests/gitlab-ci/verify_kkrimp.yml
diff --git a/ElementDataBase/Bi83.pot b/ElementDataBase/Bi83.pot
new file mode 100644
index 0000000000000000000000000000000000000000..a5bf472da8302772700c6f183ff25622614e95af
--- /dev/null
+++ b/ElementDataBase/Bi83.pot
@@ -0,0 +1,393 @@
+ SET HEADER SET HEADER SET HEADER VWN
+RWS = 3.0000 S1 = 15.0000 IRS1 = 1501 BR = 0.0002
+ZTOTI = 83.0000 ZVALI= 5.0000 NSEC = 6 EINF = -0.8000
+ 1s -0.66581904D+04
+ 2s -0.11960670D+04
+ 3s -0.28816249D+03
+ 4s -0.65875111D+02
+ 5s -0.11122339D+02
+ 2p -0.10236535D+04
+ 3p -0.23888858D+03
+ 4p -0.49721207D+02
+ 5p -0.65531353D+01
+ 3d -0.18921115D+03
+ 4d -0.31230217D+02
+ 5d -0.14771281D+01
+ 4f -0.10847212D+02
+ 0.16958870D+04 0.15283100D+04 0.13594739D+04 0.12888273D+04
+ 0.12484627D+04 0.12219777D+04 0.12030884D+04 0.11888616D+04
+ 0.11777256D+04 0.11687551D+04 0.11613662D+04 0.11551710D+04
+ 0.11499008D+04 0.11453634D+04 0.11414169D+04 0.11379544D+04
+ 0.11348940D+04 0.11321711D+04 0.11297346D+04 0.11275435D+04
+ 0.11255642D+04 0.11237690D+04 0.11221350D+04 0.11206428D+04
+ 0.11192763D+04 0.11180216D+04 0.11168667D+04 0.11158014D+04
+ 0.11148169D+04 0.11139054D+04 0.11130601D+04 0.11122752D+04
+ 0.11115452D+04 0.11108656D+04 0.11102322D+04 0.11096413D+04
+ 0.11090895D+04 0.11085740D+04 0.11080920D+04 0.11076410D+04
+ 0.11072189D+04 0.11068237D+04 0.11064536D+04 0.11061068D+04
+ 0.11057820D+04 0.11054776D+04 0.11051925D+04 0.11049254D+04
+ 0.11046753D+04 0.11044411D+04 0.11042220D+04 0.11040172D+04
+ 0.11038257D+04 0.11036469D+04 0.11034802D+04 0.11033248D+04
+ 0.11031802D+04 0.11030458D+04 0.11029211D+04 0.11028057D+04
+ 0.11026990D+04 0.11026007D+04 0.11025104D+04 0.11024277D+04
+ 0.11023522D+04 0.11022837D+04 0.11022217D+04 0.11021661D+04
+ 0.11021165D+04 0.11020727D+04 0.11020344D+04 0.11020014D+04
+ 0.11019735D+04 0.11019505D+04 0.11019322D+04 0.11019183D+04
+ 0.11019088D+04 0.11019034D+04 0.11019020D+04 0.11019044D+04
+ 0.11019105D+04 0.11019202D+04 0.11019332D+04 0.11019496D+04
+ 0.11019691D+04 0.11019917D+04 0.11020172D+04 0.11020456D+04
+ 0.11020767D+04 0.11021105D+04 0.11021468D+04 0.11021856D+04
+ 0.11022268D+04 0.11022702D+04 0.11023159D+04 0.11023638D+04
+ 0.11024137D+04 0.11024657D+04 0.11025196D+04 0.11025754D+04
+ 0.11026330D+04 0.11026924D+04 0.11027535D+04 0.11028163D+04
+ 0.11028806D+04 0.11029466D+04 0.11030140D+04 0.11030829D+04
+ 0.11031532D+04 0.11032249D+04 0.11032979D+04 0.11033722D+04
+ 0.11034478D+04 0.11035246D+04 0.11036026D+04 0.11036817D+04
+ 0.11037619D+04 0.11038432D+04 0.11039255D+04 0.11040089D+04
+ 0.11040932D+04 0.11041785D+04 0.11042647D+04 0.11043518D+04
+ 0.11044398D+04 0.11045286D+04 0.11046183D+04 0.11047087D+04
+ 0.11047999D+04 0.11048919D+04 0.11049846D+04 0.11050780D+04
+ 0.11051721D+04 0.11052668D+04 0.11053622D+04 0.11054583D+04
+ 0.11055549D+04 0.11056521D+04 0.11057499D+04 0.11058482D+04
+ 0.11059470D+04 0.11060464D+04 0.11061463D+04 0.11062466D+04
+ 0.11063474D+04 0.11064487D+04 0.11065504D+04 0.11066525D+04
+ 0.11067550D+04 0.11068579D+04 0.11069612D+04 0.11070648D+04
+ 0.11071688D+04 0.11072731D+04 0.11073778D+04 0.11074827D+04
+ 0.11075880D+04 0.11076935D+04 0.11077993D+04 0.11079054D+04
+ 0.11080117D+04 0.11081183D+04 0.11082250D+04 0.11083320D+04
+ 0.11084392D+04 0.11085466D+04 0.11086541D+04 0.11087618D+04
+ 0.11088697D+04 0.11089777D+04 0.11090859D+04 0.11091942D+04
+ 0.11093026D+04 0.11094111D+04 0.11095197D+04 0.11096283D+04
+ 0.11097371D+04 0.11098459D+04 0.11099548D+04 0.11100637D+04
+ 0.11101727D+04 0.11102817D+04 0.11103907D+04 0.11104997D+04
+ 0.11106087D+04 0.11107177D+04 0.11108267D+04 0.11109356D+04
+ 0.11110445D+04 0.11111534D+04 0.11112622D+04 0.11113709D+04
+ 0.11114796D+04 0.11115882D+04 0.11116967D+04 0.11118051D+04
+ 0.11119133D+04 0.11120215D+04 0.11121295D+04 0.11122374D+04
+ 0.11123451D+04 0.11124527D+04 0.11125602D+04 0.11126674D+04
+ 0.11127745D+04 0.11128813D+04 0.11129880D+04 0.11130945D+04
+ 0.11132007D+04 0.11133068D+04 0.11134125D+04 0.11135181D+04
+ 0.11136234D+04 0.11137284D+04 0.11138331D+04 0.11139376D+04
+ 0.11140418D+04 0.11141457D+04 0.11142493D+04 0.11143525D+04
+ 0.11144554D+04 0.11145580D+04 0.11146603D+04 0.11147622D+04
+ 0.11148637D+04 0.11149649D+04 0.11150656D+04 0.11151660D+04
+ 0.11152660D+04 0.11153655D+04 0.11154647D+04 0.11155634D+04
+ 0.11156617D+04 0.11157595D+04 0.11158569D+04 0.11159538D+04
+ 0.11160502D+04 0.11161461D+04 0.11162415D+04 0.11163364D+04
+ 0.11164308D+04 0.11165247D+04 0.11166180D+04 0.11167108D+04
+ 0.11168030D+04 0.11168946D+04 0.11169856D+04 0.11170761D+04
+ 0.11171659D+04 0.11172552D+04 0.11173438D+04 0.11174318D+04
+ 0.11175191D+04 0.11176058D+04 0.11176918D+04 0.11177771D+04
+ 0.11178617D+04 0.11179456D+04 0.11180288D+04 0.11181113D+04
+ 0.11181930D+04 0.11182740D+04 0.11183542D+04 0.11184337D+04
+ 0.11185123D+04 0.11185902D+04 0.11186672D+04 0.11187435D+04
+ 0.11188189D+04 0.11188934D+04 0.11189671D+04 0.11190399D+04
+ 0.11191118D+04 0.11191828D+04 0.11192530D+04 0.11193222D+04
+ 0.11193904D+04 0.11194577D+04 0.11195240D+04 0.11195894D+04
+ 0.11196538D+04 0.11197171D+04 0.11197795D+04 0.11198408D+04
+ 0.11199011D+04 0.11199603D+04 0.11200184D+04 0.11200755D+04
+ 0.11201314D+04 0.11201863D+04 0.11202400D+04 0.11202925D+04
+ 0.11203439D+04 0.11203941D+04 0.11204432D+04 0.11204910D+04
+ 0.11205376D+04 0.11205830D+04 0.11206271D+04 0.11206699D+04
+ 0.11207115D+04 0.11207518D+04 0.11207907D+04 0.11208284D+04
+ 0.11208647D+04 0.11208996D+04 0.11209331D+04 0.11209653D+04
+ 0.11209960D+04 0.11210253D+04 0.11210532D+04 0.11210796D+04
+ 0.11211046D+04 0.11211280D+04 0.11211499D+04 0.11211703D+04
+ 0.11211892D+04 0.11212065D+04 0.11212222D+04 0.11212363D+04
+ 0.11212488D+04 0.11212597D+04 0.11212689D+04 0.11212764D+04
+ 0.11212823D+04 0.11212864D+04 0.11212889D+04 0.11212895D+04
+ 0.11212885D+04 0.11212856D+04 0.11212809D+04 0.11212744D+04
+ 0.11212661D+04 0.11212560D+04 0.11212439D+04 0.11212300D+04
+ 0.11212141D+04 0.11211963D+04 0.11211766D+04 0.11211548D+04
+ 0.11211311D+04 0.11211054D+04 0.11210776D+04 0.11210478D+04
+ 0.11210159D+04 0.11209819D+04 0.11209458D+04 0.11209076D+04
+ 0.11208672D+04 0.11208246D+04 0.11207798D+04 0.11207328D+04
+ 0.11206836D+04 0.11206321D+04 0.11205783D+04 0.11205223D+04
+ 0.11204638D+04 0.11204031D+04 0.11203400D+04 0.11202745D+04
+ 0.11202065D+04 0.11201362D+04 0.11200634D+04 0.11199881D+04
+ 0.11199103D+04 0.11198300D+04 0.11197472D+04 0.11196617D+04
+ 0.11195737D+04 0.11194831D+04 0.11193899D+04 0.11192940D+04
+ 0.11191954D+04 0.11190941D+04 0.11189901D+04 0.11188834D+04
+ 0.11187738D+04 0.11186615D+04 0.11185464D+04 0.11184284D+04
+ 0.11183076D+04 0.11181839D+04 0.11180573D+04 0.11179278D+04
+ 0.11177953D+04 0.11176598D+04 0.11175214D+04 0.11173799D+04
+ 0.11172354D+04 0.11170878D+04 0.11169371D+04 0.11167833D+04
+ 0.11166264D+04 0.11164663D+04 0.11163030D+04 0.11161365D+04
+ 0.11159668D+04 0.11157938D+04 0.11156176D+04 0.11154380D+04
+ 0.11152552D+04 0.11150690D+04 0.11148794D+04 0.11146864D+04
+ 0.11144901D+04 0.11142903D+04 0.11140870D+04 0.11138802D+04
+ 0.11136700D+04 0.11134562D+04 0.11132388D+04 0.11130179D+04
+ 0.11127934D+04 0.11125653D+04 0.11123335D+04 0.11120981D+04
+ 0.11118590D+04 0.11116161D+04 0.11113696D+04 0.11111193D+04
+ 0.11108652D+04 0.11106073D+04 0.11103456D+04 0.11100801D+04
+ 0.11098107D+04 0.11095375D+04 0.11092603D+04 0.11089792D+04
+ 0.11086942D+04 0.11084052D+04 0.11081122D+04 0.11078152D+04
+ 0.11075142D+04 0.11072091D+04 0.11069000D+04 0.11065868D+04
+ 0.11062695D+04 0.11059480D+04 0.11056224D+04 0.11052927D+04
+ 0.11049587D+04 0.11046206D+04 0.11042783D+04 0.11039317D+04
+ 0.11035808D+04 0.11032257D+04 0.11028663D+04 0.11025026D+04
+ 0.11021345D+04 0.11017622D+04 0.11013854D+04 0.11010043D+04
+ 0.11006188D+04 0.11002289D+04 0.10998345D+04 0.10994358D+04
+ 0.10990325D+04 0.10986248D+04 0.10982127D+04 0.10977960D+04
+ 0.10973748D+04 0.10969491D+04 0.10965189D+04 0.10960841D+04
+ 0.10956447D+04 0.10952008D+04 0.10947522D+04 0.10942991D+04
+ 0.10938414D+04 0.10933790D+04 0.10929120D+04 0.10924404D+04
+ 0.10919641D+04 0.10914832D+04 0.10909975D+04 0.10905072D+04
+ 0.10900122D+04 0.10895125D+04 0.10890081D+04 0.10884990D+04
+ 0.10879851D+04 0.10874666D+04 0.10869433D+04 0.10864152D+04
+ 0.10858824D+04 0.10853448D+04 0.10848025D+04 0.10842555D+04
+ 0.10837036D+04 0.10831470D+04 0.10825856D+04 0.10820194D+04
+ 0.10814484D+04 0.10808727D+04 0.10802922D+04 0.10797068D+04
+ 0.10791167D+04 0.10785218D+04 0.10779221D+04 0.10773176D+04
+ 0.10767083D+04 0.10760943D+04 0.10754754D+04 0.10748517D+04
+ 0.10742233D+04 0.10735900D+04 0.10729520D+04 0.10723092D+04
+ 0.10716616D+04 0.10710092D+04 0.10703521D+04 0.10696902D+04
+ 0.10690235D+04 0.10683521D+04 0.10676759D+04 0.10669950D+04
+ 0.10663093D+04 0.10656188D+04 0.10649237D+04 0.10642238D+04
+ 0.10635192D+04 0.10628099D+04 0.10620958D+04 0.10613771D+04
+ 0.10606537D+04 0.10599256D+04 0.10591928D+04 0.10584553D+04
+ 0.10577132D+04 0.10569665D+04 0.10562151D+04 0.10554590D+04
+ 0.10546984D+04 0.10539331D+04 0.10531632D+04 0.10523887D+04
+ 0.10516097D+04 0.10508260D+04 0.10500378D+04 0.10492451D+04
+ 0.10484477D+04 0.10476459D+04 0.10468395D+04 0.10460286D+04
+ 0.10452133D+04 0.10443934D+04 0.10435690D+04 0.10427402D+04
+ 0.10419068D+04 0.10410691D+04 0.10402269D+04 0.10393802D+04
+ 0.10385291D+04 0.10376736D+04 0.10368137D+04 0.10359494D+04
+ 0.10350808D+04 0.10342077D+04 0.10333303D+04 0.10324485D+04
+ 0.10315623D+04 0.10306718D+04 0.10297770D+04 0.10288778D+04
+ 0.10279743D+04 0.10270665D+04 0.10261544D+04 0.10252380D+04
+ 0.10243172D+04 0.10233922D+04 0.10224629D+04 0.10215293D+04
+ 0.10205915D+04 0.10196494D+04 0.10187030D+04 0.10177523D+04
+ 0.10167974D+04 0.10158382D+04 0.10148748D+04 0.10139071D+04
+ 0.10129352D+04 0.10119590D+04 0.10109786D+04 0.10099939D+04
+ 0.10090050D+04 0.10080118D+04 0.10070144D+04 0.10060127D+04
+ 0.10050068D+04 0.10039966D+04 0.10029822D+04 0.10019635D+04
+ 0.10009406D+04 0.99991342D+03 0.99888197D+03 0.99784626D+03
+ 0.99680629D+03 0.99576204D+03 0.99471352D+03 0.99366073D+03
+ 0.99260366D+03 0.99154230D+03 0.99047666D+03 0.98940672D+03
+ 0.98833250D+03 0.98725398D+03 0.98617115D+03 0.98508403D+03
+ 0.98399260D+03 0.98289686D+03 0.98179681D+03 0.98069244D+03
+ 0.97958376D+03 0.97847076D+03 0.97735345D+03 0.97623181D+03
+ 0.97510586D+03 0.97397558D+03 0.97284099D+03 0.97170208D+03
+ 0.97055886D+03 0.96941132D+03 0.96825947D+03 0.96710332D+03
+ 0.96594286D+03 0.96477811D+03 0.96360906D+03 0.96243573D+03
+ 0.96125812D+03 0.96007624D+03 0.95889011D+03 0.95769972D+03
+ 0.95650509D+03 0.95530622D+03 0.95410314D+03 0.95289586D+03
+ 0.95168438D+03 0.95046872D+03 0.94924890D+03 0.94802493D+03
+ 0.94679682D+03 0.94556460D+03 0.94432828D+03 0.94308787D+03
+ 0.94184341D+03 0.94059490D+03 0.93934236D+03 0.93808581D+03
+ 0.93682528D+03 0.93556079D+03 0.93429235D+03 0.93301998D+03
+ 0.93174371D+03 0.93046355D+03 0.92917953D+03 0.92789167D+03
+ 0.92659999D+03 0.92530451D+03 0.92400525D+03 0.92270223D+03
+ 0.92139548D+03 0.92008500D+03 0.91877082D+03 0.91745296D+03
+ 0.91613144D+03 0.91480628D+03 0.91347748D+03 0.91214508D+03
+ 0.91080908D+03 0.90946951D+03 0.90812637D+03 0.90677968D+03
+ 0.90542945D+03 0.90407570D+03 0.90271843D+03 0.90135766D+03
+ 0.89999340D+03 0.89862566D+03 0.89725444D+03 0.89587976D+03
+ 0.89450161D+03 0.89312000D+03 0.89173495D+03 0.89034645D+03
+ 0.88895450D+03 0.88755911D+03 0.88616028D+03 0.88475801D+03
+ 0.88335230D+03 0.88194315D+03 0.88053055D+03 0.87911450D+03
+ 0.87769501D+03 0.87627206D+03 0.87484566D+03 0.87341579D+03
+ 0.87198246D+03 0.87054565D+03 0.86910536D+03 0.86766159D+03
+ 0.86621432D+03 0.86476355D+03 0.86330927D+03 0.86185148D+03
+ 0.86039016D+03 0.85892531D+03 0.85745693D+03 0.85598499D+03
+ 0.85450950D+03 0.85303045D+03 0.85154783D+03 0.85006164D+03
+ 0.84857186D+03 0.84707849D+03 0.84558153D+03 0.84408096D+03
+ 0.84257679D+03 0.84106901D+03 0.83955761D+03 0.83804259D+03
+ 0.83652396D+03 0.83500170D+03 0.83347582D+03 0.83194631D+03
+ 0.83041318D+03 0.82887642D+03 0.82733605D+03 0.82579205D+03
+ 0.82424444D+03 0.82269323D+03 0.82113841D+03 0.81957999D+03
+ 0.81801798D+03 0.81645239D+03 0.81488323D+03 0.81331051D+03
+ 0.81173423D+03 0.81015442D+03 0.80857109D+03 0.80698425D+03
+ 0.80539391D+03 0.80380009D+03 0.80220282D+03 0.80060209D+03
+ 0.79899795D+03 0.79739040D+03 0.79577946D+03 0.79416516D+03
+ 0.79254752D+03 0.79092656D+03 0.78930230D+03 0.78767476D+03
+ 0.78604398D+03 0.78440997D+03 0.78277277D+03 0.78113238D+03
+ 0.77948885D+03 0.77784220D+03 0.77619245D+03 0.77453963D+03
+ 0.77288376D+03 0.77122487D+03 0.76956299D+03 0.76789815D+03
+ 0.76623037D+03 0.76455967D+03 0.76288608D+03 0.76120963D+03
+ 0.75953034D+03 0.75784823D+03 0.75616333D+03 0.75447567D+03
+ 0.75278526D+03 0.75109213D+03 0.74939630D+03 0.74769779D+03
+ 0.74599662D+03 0.74429281D+03 0.74258638D+03 0.74087735D+03
+ 0.73916574D+03 0.73745156D+03 0.73573483D+03 0.73401556D+03
+ 0.73229377D+03 0.73056948D+03 0.72884270D+03 0.72711344D+03
+ 0.72538172D+03 0.72364755D+03 0.72191093D+03 0.72017190D+03
+ 0.71843044D+03 0.71668659D+03 0.71494034D+03 0.71319171D+03
+ 0.71144072D+03 0.70968738D+03 0.70793169D+03 0.70617368D+03
+ 0.70441335D+03 0.70265072D+03 0.70088580D+03 0.69911861D+03
+ 0.69734917D+03 0.69557749D+03 0.69380360D+03 0.69202750D+03
+ 0.69024922D+03 0.68846878D+03 0.68668620D+03 0.68490151D+03
+ 0.68311472D+03 0.68132586D+03 0.67953497D+03 0.67774205D+03
+ 0.67594715D+03 0.67415029D+03 0.67235150D+03 0.67055081D+03
+ 0.66874824D+03 0.66694384D+03 0.66513762D+03 0.66332963D+03
+ 0.66151989D+03 0.65970843D+03 0.65789529D+03 0.65608050D+03
+ 0.65426409D+03 0.65244609D+03 0.65062653D+03 0.64880544D+03
+ 0.64698285D+03 0.64515879D+03 0.64333329D+03 0.64150637D+03
+ 0.63967807D+03 0.63784840D+03 0.63601739D+03 0.63418506D+03
+ 0.63235143D+03 0.63051654D+03 0.62868038D+03 0.62684299D+03
+ 0.62500439D+03 0.62316458D+03 0.62132359D+03 0.61948142D+03
+ 0.61763810D+03 0.61579364D+03 0.61394804D+03 0.61210133D+03
+ 0.61025350D+03 0.60840458D+03 0.60655457D+03 0.60470348D+03
+ 0.60285132D+03 0.60099811D+03 0.59914385D+03 0.59728855D+03
+ 0.59543222D+03 0.59357488D+03 0.59171653D+03 0.58985720D+03
+ 0.58799688D+03 0.58613560D+03 0.58427337D+03 0.58241021D+03
+ 0.58054614D+03 0.57868117D+03 0.57681532D+03 0.57494863D+03
+ 0.57308110D+03 0.57121277D+03 0.56934366D+03 0.56747381D+03
+ 0.56560324D+03 0.56373198D+03 0.56186008D+03 0.55998756D+03
+ 0.55811447D+03 0.55624085D+03 0.55436674D+03 0.55249218D+03
+ 0.55061722D+03 0.54874190D+03 0.54686629D+03 0.54499042D+03
+ 0.54311436D+03 0.54123816D+03 0.53936187D+03 0.53748555D+03
+ 0.53560926D+03 0.53373306D+03 0.53185702D+03 0.52998119D+03
+ 0.52810564D+03 0.52623043D+03 0.52435562D+03 0.52248128D+03
+ 0.52060748D+03 0.51873428D+03 0.51686173D+03 0.51498992D+03
+ 0.51311889D+03 0.51124872D+03 0.50937947D+03 0.50751119D+03
+ 0.50564394D+03 0.50377779D+03 0.50191279D+03 0.50004900D+03
+ 0.49818648D+03 0.49632526D+03 0.49446541D+03 0.49260697D+03
+ 0.49074999D+03 0.48889452D+03 0.48704059D+03 0.48518824D+03
+ 0.48333752D+03 0.48148845D+03 0.47964108D+03 0.47779543D+03
+ 0.47595153D+03 0.47410942D+03 0.47226910D+03 0.47043062D+03
+ 0.46859399D+03 0.46675924D+03 0.46492638D+03 0.46309543D+03
+ 0.46126642D+03 0.45943936D+03 0.45761426D+03 0.45579115D+03
+ 0.45397005D+03 0.45215097D+03 0.45033393D+03 0.44851894D+03
+ 0.44670604D+03 0.44489524D+03 0.44308656D+03 0.44128002D+03
+ 0.43947566D+03 0.43767349D+03 0.43587355D+03 0.43407585D+03
+ 0.43228043D+03 0.43048732D+03 0.42869654D+03 0.42690814D+03
+ 0.42512214D+03 0.42333856D+03 0.42155746D+03 0.41977884D+03
+ 0.41800276D+03 0.41622923D+03 0.41445829D+03 0.41268996D+03
+ 0.41092428D+03 0.40916126D+03 0.40740093D+03 0.40564332D+03
+ 0.40388843D+03 0.40213630D+03 0.40038694D+03 0.39864035D+03
+ 0.39689655D+03 0.39515554D+03 0.39341734D+03 0.39168194D+03
+ 0.38994934D+03 0.38821955D+03 0.38649256D+03 0.38476836D+03
+ 0.38304694D+03 0.38132830D+03 0.37961243D+03 0.37789930D+03
+ 0.37618890D+03 0.37448123D+03 0.37277626D+03 0.37107398D+03
+ 0.36937436D+03 0.36767739D+03 0.36598306D+03 0.36429134D+03
+ 0.36260221D+03 0.36091567D+03 0.35923168D+03 0.35755025D+03
+ 0.35587134D+03 0.35419496D+03 0.35252109D+03 0.35084972D+03
+ 0.34918083D+03 0.34751444D+03 0.34585052D+03 0.34418909D+03
+ 0.34253013D+03 0.34087366D+03 0.33921967D+03 0.33756819D+03
+ 0.33591921D+03 0.33427275D+03 0.33262882D+03 0.33098745D+03
+ 0.32934866D+03 0.32771247D+03 0.32607890D+03 0.32444798D+03
+ 0.32281976D+03 0.32119425D+03 0.31957150D+03 0.31795155D+03
+ 0.31633443D+03 0.31472020D+03 0.31310889D+03 0.31150056D+03
+ 0.30989526D+03 0.30829303D+03 0.30669393D+03 0.30509802D+03
+ 0.30350534D+03 0.30191597D+03 0.30032995D+03 0.29874735D+03
+ 0.29716823D+03 0.29559265D+03 0.29402066D+03 0.29245234D+03
+ 0.29088775D+03 0.28932695D+03 0.28776999D+03 0.28621695D+03
+ 0.28466789D+03 0.28312286D+03 0.28158193D+03 0.28004517D+03
+ 0.27851262D+03 0.27698435D+03 0.27546042D+03 0.27394088D+03
+ 0.27242579D+03 0.27091521D+03 0.26940918D+03 0.26790776D+03
+ 0.26641099D+03 0.26491893D+03 0.26343163D+03 0.26194912D+03
+ 0.26047146D+03 0.25899868D+03 0.25753082D+03 0.25606793D+03
+ 0.25461004D+03 0.25315718D+03 0.25170939D+03 0.25026671D+03
+ 0.24882915D+03 0.24739676D+03 0.24596956D+03 0.24454757D+03
+ 0.24313083D+03 0.24171936D+03 0.24031317D+03 0.23891230D+03
+ 0.23751677D+03 0.23612659D+03 0.23474178D+03 0.23336237D+03
+ 0.23198838D+03 0.23061981D+03 0.22925669D+03 0.22789904D+03
+ 0.22654688D+03 0.22520021D+03 0.22385905D+03 0.22252343D+03
+ 0.22119335D+03 0.21986883D+03 0.21854989D+03 0.21723653D+03
+ 0.21592878D+03 0.21462664D+03 0.21333013D+03 0.21203925D+03
+ 0.21075402D+03 0.20947445D+03 0.20820056D+03 0.20693234D+03
+ 0.20566980D+03 0.20441296D+03 0.20316182D+03 0.20191639D+03
+ 0.20067666D+03 0.19944265D+03 0.19821435D+03 0.19699177D+03
+ 0.19577491D+03 0.19456377D+03 0.19335834D+03 0.19215862D+03
+ 0.19096462D+03 0.18977632D+03 0.18859372D+03 0.18741681D+03
+ 0.18624558D+03 0.18508004D+03 0.18392016D+03 0.18276594D+03
+ 0.18161738D+03 0.18047444D+03 0.17933714D+03 0.17820545D+03
+ 0.17707935D+03 0.17595885D+03 0.17484392D+03 0.17373455D+03
+ 0.17263072D+03 0.17153243D+03 0.17043965D+03 0.16935238D+03
+ 0.16827059D+03 0.16719427D+03 0.16612340D+03 0.16505798D+03
+ 0.16399798D+03 0.16294339D+03 0.16189419D+03 0.16085038D+03
+ 0.15981192D+03 0.15877882D+03 0.15775105D+03 0.15672860D+03
+ 0.15571145D+03 0.15469959D+03 0.15369301D+03 0.15269169D+03
+ 0.15169562D+03 0.15070478D+03 0.14971916D+03 0.14873875D+03
+ 0.14776353D+03 0.14679349D+03 0.14582862D+03 0.14486891D+03
+ 0.14391433D+03 0.14296489D+03 0.14202057D+03 0.14108134D+03
+ 0.14014722D+03 0.13921817D+03 0.13829419D+03 0.13737526D+03
+ 0.13646139D+03 0.13555254D+03 0.13464871D+03 0.13374989D+03
+ 0.13285607D+03 0.13196723D+03 0.13108336D+03 0.13020445D+03
+ 0.12933048D+03 0.12846145D+03 0.12759735D+03 0.12673815D+03
+ 0.12588384D+03 0.12503442D+03 0.12418987D+03 0.12335017D+03
+ 0.12251531D+03 0.12168528D+03 0.12086007D+03 0.12003966D+03
+ 0.11922403D+03 0.11841317D+03 0.11760707D+03 0.11680570D+03
+ 0.11600907D+03 0.11521714D+03 0.11442990D+03 0.11364734D+03
+ 0.11286945D+03 0.11209620D+03 0.11132757D+03 0.11056356D+03
+ 0.10980414D+03 0.10904929D+03 0.10829901D+03 0.10755326D+03
+ 0.10681204D+03 0.10607532D+03 0.10534309D+03 0.10461532D+03
+ 0.10389201D+03 0.10317312D+03 0.10245865D+03 0.10174857D+03
+ 0.10104286D+03 0.10034151D+03 0.99644492D+02 0.98951791D+02
+ 0.98263386D+02 0.97579258D+02 0.96899389D+02 0.96223757D+02
+ 0.95552345D+02 0.94885132D+02 0.94222099D+02 0.93563227D+02
+ 0.92908497D+02 0.92257888D+02 0.91611382D+02 0.90968959D+02
+ 0.90330600D+02 0.89696286D+02 0.89065998D+02 0.88439716D+02
+ 0.87817422D+02 0.87199095D+02 0.86584719D+02 0.85974272D+02
+ 0.85367736D+02 0.84765093D+02 0.84166323D+02 0.83571408D+02
+ 0.82980329D+02 0.82393066D+02 0.81809601D+02 0.81229915D+02
+ 0.80653989D+02 0.80081804D+02 0.79513341D+02 0.78948582D+02
+ 0.78387508D+02 0.77830098D+02 0.77276335D+02 0.76726200D+02
+ 0.76179672D+02 0.75636734D+02 0.75097366D+02 0.74561548D+02
+ 0.74029262D+02 0.73500488D+02 0.72975207D+02 0.72453399D+02
+ 0.71935045D+02 0.71420125D+02 0.70908620D+02 0.70400511D+02
+ 0.69895777D+02 0.69394399D+02 0.68896357D+02 0.68401632D+02
+ 0.67910204D+02 0.67422053D+02 0.66937160D+02 0.66455504D+02
+ 0.65977065D+02 0.65501825D+02 0.65029763D+02 0.64560859D+02
+ 0.64095094D+02 0.63632448D+02 0.63172901D+02 0.62716433D+02
+ 0.62263025D+02 0.61812657D+02 0.61365309D+02 0.60920961D+02
+ 0.60479595D+02 0.60041191D+02 0.59605728D+02 0.59173188D+02
+ 0.58743552D+02 0.58316799D+02 0.57892912D+02 0.57471870D+02
+ 0.57053654D+02 0.56638245D+02 0.56225625D+02 0.55815774D+02
+ 0.55408674D+02 0.55004306D+02 0.54602707D+02 0.54203906D+02
+ 0.53807885D+02 0.53414626D+02 0.53024111D+02 0.52636323D+02
+ 0.52251245D+02 0.51868858D+02 0.51489146D+02 0.51112092D+02
+ 0.50737678D+02 0.50365888D+02 0.49996704D+02 0.49630110D+02
+ 0.49266089D+02 0.48904623D+02 0.48545698D+02 0.48189295D+02
+ 0.47835399D+02 0.47483994D+02 0.47135062D+02 0.46788589D+02
+ 0.46444557D+02 0.46102951D+02 0.45763755D+02 0.45426953D+02
+ 0.45092530D+02 0.44760469D+02 0.44430755D+02 0.44103373D+02
+ 0.43778307D+02 0.43455543D+02 0.43135064D+02 0.42816855D+02
+ 0.42500903D+02 0.42187191D+02 0.41875705D+02 0.41566430D+02
+ 0.41259351D+02 0.40954455D+02 0.40651726D+02 0.40351151D+02
+ 0.40052714D+02 0.39756403D+02 0.39462202D+02 0.39170098D+02
+ 0.38880078D+02 0.38592127D+02 0.38306232D+02 0.38022380D+02
+ 0.37740557D+02 0.37460750D+02 0.37182946D+02 0.36907132D+02
+ 0.36633295D+02 0.36361423D+02 0.36091503D+02 0.35823522D+02
+ 0.35557468D+02 0.35293330D+02 0.35031093D+02 0.34770748D+02
+ 0.34512282D+02 0.34255682D+02 0.34000938D+02 0.33748038D+02
+ 0.33496970D+02 0.33247722D+02 0.33000285D+02 0.32754646D+02
+ 0.32510795D+02 0.32268719D+02 0.32028409D+02 0.31789854D+02
+ 0.31553042D+02 0.31317963D+02 0.31084606D+02 0.30852961D+02
+ 0.30623016D+02 0.30394762D+02 0.30168187D+02 0.29943282D+02
+ 0.29720035D+02 0.29498437D+02 0.29278477D+02 0.29060143D+02
+ 0.28843427D+02 0.28628317D+02 0.28414804D+02 0.28202876D+02
+ 0.27992524D+02 0.27783736D+02 0.27576504D+02 0.27370815D+02
+ 0.27166660D+02 0.26964029D+02 0.26762911D+02 0.26563295D+02
+ 0.26365172D+02 0.26168530D+02 0.25973360D+02 0.25779651D+02
+ 0.25587393D+02 0.25396574D+02 0.25207186D+02 0.25019217D+02
+ 0.24832658D+02 0.24647497D+02 0.24463724D+02 0.24281330D+02
+ 0.24100303D+02 0.23920634D+02 0.23742313D+02 0.23565329D+02
+ 0.23389671D+02 0.23215330D+02 0.23042297D+02 0.22870559D+02
+ 0.22700109D+02 0.22530935D+02 0.22363028D+02 0.22196378D+02
+ 0.22030975D+02 0.21866810D+02 0.21703873D+02 0.21542153D+02
+ 0.21381643D+02 0.21222332D+02 0.21064211D+02 0.20907271D+02
+ 0.20751502D+02 0.20596896D+02 0.20443443D+02 0.20291134D+02
+ 0.20139961D+02 0.19989915D+02 0.19840987D+02 0.19693168D+02
+ 0.19546451D+02 0.19400826D+02 0.19256286D+02 0.19112822D+02
+ 0.18970426D+02 0.18829089D+02 0.18688805D+02 0.18549564D+02
+ 0.18411360D+02 0.18274185D+02 0.18138030D+02 0.18002889D+02
+ 0.17868753D+02 0.17735616D+02 0.17603470D+02 0.17472308D+02
+ 0.17342123D+02 0.17212908D+02 0.17084655D+02 0.16957357D+02
+ 0.16831008D+02 0.16705601D+02 0.16581129D+02 0.16457585D+02
+ 0.16334963D+02 0.16213255D+02 0.16092455D+02 0.15972557D+02
+ 0.15853553D+02 0.15735438D+02 0.15618205D+02 0.15501847D+02
+ 0.15386357D+02 0.15271730D+02 0.15157958D+02 0.15045036D+02
+ 0.14932955D+02 0.14821711D+02 0.14711296D+02 0.14601703D+02
+ 0.14492926D+02 0.14384958D+02 0.14277793D+02 0.14171423D+02
+ 0.14065842D+02 0.13961043D+02 0.13857019D+02 0.13753763D+02
+ 0.13651269D+02 0.13549529D+02 0.13448537D+02 0.13348285D+02
+ 0.13248768D+02 0.13149978D+02 0.13051908D+02 0.12954553D+02
+ 0.12857906D+02 0.12761960D+02 0.12666709D+02 0.12572148D+02
+ 0.12478271D+02 0.12385073D+02 0.12292548D+02 0.12200690D+02
+ 0.12109497D+02 0.12018962D+02 0.11929082D+02 0.11839854D+02
+ 0.11751272D+02 0.11663335D+02 0.11576039D+02 0.11489382D+02
+ 0.11403361D+02 0.11317974D+02 0.11233220D+02 0.11149096D+02
+ 0.11065602D+02
+END*
diff --git a/source/KKRnano/regtests/run_test.sh b/source/KKRnano/regtests/run_test.sh
index 02cfb37a9005361d93f7ba2f7ecf5a80be9a0971..117c9a1277429a052cdbe6bd15419a991e8859ec 100755
--- a/source/KKRnano/regtests/run_test.sh
+++ b/source/KKRnano/regtests/run_test.sh
@@ -1,6 +1,8 @@
#!/bin/sh
ARCHIVE=loggs
+export LD_LIBRARY_PATH=$MKLROOT/lib/intel64:$LD_LIBRARY_PATH
+
## today's date, hour, minute
day=`date "+%Y%m%d%H%M"`
diff --git a/source/KKRnano/regtests/tests.py b/source/KKRnano/regtests/tests.py
index 96d2a4386e54834b0ab57213c57915deee2c6e67..ede4da137b7696030b4fd4ae4c0e515ebfbfc278 100755
--- a/source/KKRnano/regtests/tests.py
+++ b/source/KKRnano/regtests/tests.py
@@ -12,7 +12,7 @@ TESTDIR = os.getcwd() ### perform the calculation in the current working directo
DECIMALS = 6 ### 8=all digits, 6 should be enough
DEFAULT_lmax = 3
DEFAULT_nranks = 1
-DEFAULT_nthreads = 1
+DEFAULT_nthreads = 4
direct = 4 ##
iterative = 3 ##
DEFAULT_solver = iterative
@@ -21,36 +21,42 @@ ShowMD5 = True
AllMPIs = 1 # 1=Yes, 0=No
HighLmax = True
testNocoSOC = True
+verbose = False
+MPIEXEC = 'mpirun' # 'srun'
def run_it(cmd):
"""Run cmd, suppressing output. Returns output from stdout and exit code"""
start_time = time.time()
+ if verbose:
+ print('Run command "{0}"'.format(cmd))
proc = subprocess.Popen(cmd, stdout=subprocess.PIPE, close_fds=True, preexec_fn=os.setsid, shell=True)
out, err = proc.communicate()
end_time = time.time()
tim = end_time - start_time
- return out, proc.returncode, tim
+ return out.decode('utf-8'), proc.returncode, tim
def get_energy(string):
try:
match = list(re.finditer(r"^.*TOTAL ENERGY in ryd. :(.*)$", string, re.M))[-1] # get last match only
except:
- print string
+ print(string)
raise ArgumentError
if match is not None:
return float(match.group(1))
else:
raise ArgumentError
-def KKRnano(inputdir, nranks=DEFAULT_nranks, nthreads=DEFAULT_nthreads, solver=DEFAULT_solver, lmax=DEFAULT_lmax, Lly=DEFAULT_Lly):
+def KKRnano(inputdir, nranks=DEFAULT_nranks, nthreads=DEFAULT_nthreads, solver=DEFAULT_solver, lmax=DEFAULT_lmax, Lly=DEFAULT_Lly, **kwargs):
"""Run KKR-calculation with input from 'inputdir' and returns the total energy"""
- #print "start KKR for", inputdir, "with lmax=",lmax, ", solver=",solver, ", nthreads=",nthreads, "nranks=",nranks
+ if verbose:
+ print("start KKR for", inputdir, "with lmax=",lmax, ", solver=",solver, ", nthreads=",nthreads, "nranks=",nranks)
+ print('test dir:', TESTDIR)
out, err, tim = run_it("./clearfiles.sh")
global ShowMD5
if ShowMD5:
out, err, tim = run_it("md5sum ./kkr.exe")
- print out
+ print(out)
ShowMD5 = False ## do not show again
for file in glob.glob(os.path.join(inputdir, '*')):
@@ -66,83 +72,111 @@ def KKRnano(inputdir, nranks=DEFAULT_nranks, nthreads=DEFAULT_nthreads, solver=D
with open("input.conf", "a") as myfile: ## append to file
myfile.write("LLY = {0}\n".format(int(Lly)))
- out, err, tim = run_it("./kkr.exe --prepare") ### start from JM-formatted potential file
+ # add other inputs
+ for key, val in kwargs.items():
+ with open("input.conf", "a") as myfile: ## append to file
+ myfile.write("{0} = {1}\n".format(key, val))
+
+ mpirun = ''
+ if MPIEXEC=='srun':
+ mpirun = 'srun -n 1 '
+ out, err, tim = run_it(mpirun + "./kkr.exe --prepare") ### start from JM-formatted potential file
## execute the code
- out, err, tim = run_it("OMP_STACKSIZE=80M OMP_NUM_THREADS={0} mpiexec -np {1} kkr.exe".format(int(nthreads), int(nranks)))
+ mpirun = 'mpirun -np'
+ if MPIEXEC=='srun':
+ mpirun = 'srun -n'
+ out, err, tim = run_it("OMP_STACKSIZE=80M OMP_NUM_THREADS={0} ".format(int(nthreads)) + mpirun + " {0} ./kkr.exe".format(int(nranks)))
+ if verbose:
+ print('out', out)
+ print('err', err)
+ print('tim', tim)
### grep the result
total_energy = get_energy(out)
- print "KKR for",inputdir," with lmax=",lmax," gives",total_energy,"Ryd",
+ msg = f"KKR for {inputdir} with lmax= {lmax} gives {total_energy} Ryd"
if solver != DEFAULT_solver:
- print ", solver=",solver,
+ msg += f", solver= {solver}"
if nthreads != DEFAULT_nthreads:
- print ", nthreads=",nthreads,
+ msg += f", nthreads= {nthreads}"
if nranks != DEFAULT_nranks:
- print ", nranks=",nranks,
+ msg += f", nranks= {nranks}"
if Lly != DEFAULT_Lly:
- print ", Lly=",Lly,
- print " in", tim," sec"
+ msg += f", Lly={Lly}"
+ msg += f" in {tim} sec"
+ print(msg)
out, err, tim = run_it("./clearfiles.sh")
return total_energy
+######################################################################################
+
class Test_alloys(unittest.TestCase):
def test_Fe8Co8(self):
"""Test random alloy of 16 atoms"""
- Etot = -42561.17620828
+ Etot = -42561.325157
for r in range(0, AllMPIs*4+1): # nranks=[1, 2, 4, 8, 16]
self.assertAlmostEqual(KKRnano("Fe8Co8", solver=direct, nranks=2**r), Etot, DECIMALS) # about 30 seconds for nranks=1
+ # total time ~2.2min
class Test_copper(unittest.TestCase):
def test_Cu4_lmax(self):
"""Test with high lmax. Works only with -heap-arrays on ifort, 4 Cu atoms in the cubic unit cell"""
- Etot = -13219.36420827
+ Etot = -13219.3620641
for r in range(0, AllMPIs*2+1): # nranks=[1, 2, 4]
self.assertAlmostEqual(KKRnano("Cu4", solver=direct, nranks=2**r), Etot, DECIMALS)
if HighLmax:
- self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=4), -13219.71809004, DECIMALS)
- self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=5), -13219.60358021, DECIMALS) # about 30 seconds
- self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=6), -13219.5622359, DECIMALS) # about 60 seconds
+ self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=4, nranks=4), -13219.716163, DECIMALS)
+ self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=5, nranks=4), -13219.6016203, DECIMALS) # about 30 seconds
+ self.assertAlmostEqual(KKRnano("Cu4", solver=direct, lmax=6, nranks=4), -13219.5603038, DECIMALS) # about 60 seconds
+ # total time ~1.6min
def test_Cu1_lmax(self):
"""Test with high lmax. Works only with -heap-arrays on ifort, 1 Cu atoms in the FCC unit cell"""
- self.assertAlmostEqual(KKRnano("Cu1", solver=direct), -3308.16564382, DECIMALS) # about 2 seconds
+ self.assertAlmostEqual(KKRnano("Cu1", solver=direct, nranks=1), -3308.14107181, DECIMALS) # about 2 seconds
if HighLmax:
- self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=4), -3308.26672862, DECIMALS) # about 4 seconds
- self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=5), -3308.23074153, DECIMALS) # about 8 seconds
- self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=6), -3308.15897626, DECIMALS) # about 16 seconds
+ self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=4, nranks=1), -3308.26072261, DECIMALS) # about 4 seconds
+ self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=5, nranks=1), -3308.22046659, DECIMALS) # about 8 seconds
+ self.assertAlmostEqual(KKRnano("Cu1", solver=direct, lmax=6, nranks=1), -3308.15010032, DECIMALS) # about 16 seconds
+ # total time ~1min
class Test_semiconductors(unittest.TestCase):
def test_GaN(self):
"""Test semiconductor in zincblende structure with 2 vacancy cells"""
- Etot = -3990.85752538
+ Etot = -3990.8515006
for r in range(0, AllMPIs*2+1): # nranks=[4, 2, 1]
self.assertAlmostEqual(KKRnano("GaN", solver=direct, nranks=2**(2-r)), Etot, DECIMALS) # about 80 seconds
+ # total time ~4.6min
def test_Si(self):
"""Test semiconductor in diamond structure with 2 vacancy cells"""
- Etot = -1155.68470407
+ Etot = -1155.68952256
for r in range(0, AllMPIs*2+1): # nranks=[1, 2, 4]
self.assertAlmostEqual(KKRnano("Si", solver=direct, nranks=2**r), Etot, DECIMALS) # about a minute
-
-# def test_ZnO(self):
-# """Test semiconductor in wurzite structure with 4 vacancy cells and voro_weights"""
-# Etot = -7405.77074357 ## test iterative solver (solver=3, default) without and with MPI
-# for r in range(0, AllMPIs*3+1): # nranks=[1, 2, 4, 8]
-# self.assertAlmostEqual(KKRnano("ZnO", nranks=2**r), Etot, DECIMALS)
-#
-# Etot = -7405.77074351
-# for r in range(0, AllMPIs*3+1): # nranks=[1, 2, 4, 8]
-# self.assertAlmostEqual(KKRnano("ZnO", solver=direct, nranks=2**r), Etot, DECIMALS)
-# ### Lloyd formula
-# self.assertAlmostEqual(KKRnano("ZnO", solver=direct, nranks=8, Lly=1), -7405.74826372, DECIMALS)
-# self.assertAlmostEqual(KKRnano("ZnO", nranks=8, Lly=1), -7405.74826372, DECIMALS)
+ # total time ~1.5min
+
+ def test_ZnO(self):
+ """Test semiconductor in wurzite structure with 4 vacancy cells and voro_weights"""
+ Etot = -7405.77043939 ## test iterative solver (solver=3, default) without and with MPI
+ for r in range(0, AllMPIs*3+1): # nranks=[1, 2, 4, 8]
+ self.assertAlmostEqual(KKRnano("ZnO", nranks=2**r), Etot, DECIMALS)
+
+ for r in range(0, AllMPIs*3+1): # nranks=[1, 2, 4, 8]
+ self.assertAlmostEqual(KKRnano("ZnO", solver=direct, nranks=2**r), Etot, DECIMALS)
+ ### Lloyd formula
+ # broken because of error message "Lloyd's formula and num_local_atoms > 1 not supported."
+ # this seems to work only if we have one MPI rank per atom
+ # i.e. put "num_atom_procs = 8" into the input.conf
+ Etot = -7405.75215722
+ self.assertAlmostEqual(KKRnano("ZnO", solver=direct, nranks=8, Lly=1, num_atom_procs=8), Etot, DECIMALS)
+ self.assertAlmostEqual(KKRnano("ZnO", nranks=8, Lly=1, num_atom_procs=8), Etot, DECIMALS)
+ # total time ~1.5min
class Test_nocosocmaterials(unittest.TestCase):
def test_MnGeB20(self):
"""Test chiral magnet MnGe B20 structure (8 atoms in unit cell)"""
- Etot = -26017.23757851
+ Etot = -26017.1505286
if testNocoSOC:
- self.assertAlmostEqual(KKRnano("MnGeB20", solver=direct, nranks=8), Etot, DECIMALS) # takes longer than other tests
+ self.assertAlmostEqual(KKRnano("MnGeB20", solver=direct, nranks=8), Etot, DECIMALS) # takes longer than other tests, ~3 mins
self.assertAlmostEqual(KKRnano("MnGeB20", solver=iterative, nranks=4), Etot, DECIMALS) # takes longer than other tests
+ # total time ~6min
unittest.main()
diff --git a/source/KKRnano/source/CalculationData_mod.F90 b/source/KKRnano/source/CalculationData_mod.F90
index 8d5cd9ad01db441b228bbcb3392937e43119bb8f..56d1adbaee85336c2635f4138a19594027b40d15 100644
--- a/source/KKRnano/source/CalculationData_mod.F90
+++ b/source/KKRnano/source/CalculationData_mod.F90
@@ -612,7 +612,7 @@ module CalculationData_mod
call create(self%mesh_a(ila), irmd, ipand)
- a_log_local = 0.025d0
+ a_log_local = params%a_log
b_log_local = inter_mesh%xrn(1)*params%alat / (exp(a_log_local * ((irmd-irid) - 1)) - 1.d0)
call initRadialMesh(self=self%mesh_a(ila), alat=params%alat, xrn=inter_mesh%xrn, &
diff --git a/source/KKRnano/source/DebugHelpers/DebugCheckArrayD_mod.f90 b/source/KKRnano/source/DebugHelpers/DebugCheckArrayD_mod.f90
deleted file mode 100644
index 283ab922187b4c4217e9f62b9914d7ff33a711c8..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/DebugHelpers/DebugCheckArrayD_mod.f90
+++ /dev/null
@@ -1,105 +0,0 @@
-! Author: Elias Rabel
-module DebugCheckArrayD_mod
- implicit none
- public
-
- type DebugCheckArrayD
- private
- double precision, allocatable :: array_data(:)
- integer :: num_elements
- character(len=32) :: array_name
- endtype
-
- contains
-
- subroutine createDebugCheckArrayD(self, array_to_check, num_elements, array_name)
- type(DebugCheckArrayD), intent(inout) :: self
- double precision, intent(in) :: array_to_check(num_elements)
- integer, intent(in) :: num_elements
- character(len=*), intent(in) :: array_name
-
- integer :: ii
-
- allocate(self%array_data(num_elements))
-
- self%num_elements = num_elements
- self%array_name = array_name
-
- do ii = 1, num_elements
- self%array_data(ii) = array_to_check(ii)
- enddo ! ii
-
- endsubroutine
-
- logical function testDebugCheckArrayD(self, array_to_check, fail_message)
- type(DebugCheckArrayD), intent(in) :: self
- double precision, intent(in) :: array_to_check(*) ! accept any array
- character(len=*), intent(in), optional :: fail_message
-
- integer :: ii
-
- testDebugCheckArrayD = .false.
-
- do ii = 1, self%num_elements
- if (self%array_data(ii) /= array_to_check(ii)) then
- write(*,*) "testDebugCheckArrayD: Arrays do not match. Element ", ii
- if (present(fail_message)) then
- write(*,*) self%array_name, fail_message
- else
- write(*,*) self%array_name
- endif
- return
- endif
- enddo ! ii
-
- testDebugCheckArrayD = .true.
-
- endfunction
-
- elemental subroutine destroyDebugCheckArrayD(self)
- type(DebugCheckArrayD), intent(inout) :: self
- integer :: ist
- deallocate(self%array_data, stat=ist) ! ignore status
- endsubroutine ! destroy
-
-endmodule
-
-!
-!program TryDebugCheckArrayD
-! use DebugCheckArrayD_mod
-! implicit none
-!
-! integer, parameter :: dimx = 10
-! integer, parameter :: dimy = 10
-!
-! double precision, dimension(dimx, dimy) :: my_array
-!
-! integer :: x, y
-! logical :: flag
-!
-! type(DebugCheckArrayD) :: db
-!
-! do y = 1, dimy
-! do x = 1, dimx
-! my_array(x,y) = x * y
-! enddo
-! enddo
-!
-! call createDebugCheckArrayD(db, my_array, dimx*dimy, "my_array")
-!
-! ! .. do something
-!
-! write(*,*) testDebugCheckArrayD(db, my_array)
-!
-! ! .. do something bad
-!
-! my_array(3,5) = -3
-!
-! write(*,*) testDebugCheckArrayD(db, my_array)
-!
-! ! use optional fail_message
-! write(*,*) testDebugCheckArrayD(db, my_array, fail_message="location: main")
-!
-!
-! call destroyDebugCheckArrayD(db)
-!endprogram
diff --git a/source/KKRnano/source/DebugHelpers/DebugCheckArrayI_mod.f90 b/source/KKRnano/source/DebugHelpers/DebugCheckArrayI_mod.f90
deleted file mode 100644
index f49e6d8618cfd96dc9dc94719ebcec87ca7eb3d3..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/DebugHelpers/DebugCheckArrayI_mod.f90
+++ /dev/null
@@ -1,105 +0,0 @@
-! Author: Elias Rabel
-module DebugCheckArrayI_mod
- implicit none
- public
-
- type DebugCheckArrayI
- private
- integer, allocatable :: array_data(:)
- integer :: num_elements
- character(len=32) :: array_name
- endtype
-
- contains
-
- subroutine createDebugCheckArrayI(self, array_to_check, num_elements, array_name)
- type(DebugCheckArrayI), intent(inout) :: self
- integer, intent(in) :: array_to_check(num_elements)
- integer, intent(in) :: num_elements
- character(len=*), intent(in) :: array_name
-
- integer :: ii
-
- allocate(self%array_data(num_elements))
-
- self%num_elements = num_elements
- self%array_name = array_name
-
- do ii = 1, num_elements
- self%array_data(ii) = array_to_check(ii)
- enddo ! ii
-
- endsubroutine
-
- logical function testDebugCheckArrayI(self, array_to_check, fail_message)
- type(DebugCheckArrayI), intent(in) :: self
- integer, intent(in) :: array_to_check(*) ! accept any array
- character(len=*), intent(in), optional :: fail_message
-
- integer :: ii
-
- testDebugCheckArrayI = .false.
-
- do ii = 1, self%num_elements
- if (self%array_data(ii) /= array_to_check(ii)) then
- write(*,*) "testDebugCheckArrayI: Arrays do not match. Element ", ii
- if (present(fail_message)) then
- write(*,*) self%array_name, fail_message
- else
- write(*,*) self%array_name
- endif
- return
- endif
- enddo ! ii
-
- testDebugCheckArrayI = .true.
-
- endfunction
-
- elemental subroutine destroyDebugCheckArrayI(self)
- type(DebugCheckArrayI), intent(inout) :: self
- integer :: ist
- deallocate(self%array_data, stat=ist) ! ignore status
- endsubroutine ! destroy
-
-endmodule
-
-!
-!program TryDebugCheckArrayI
-! use DebugCheckArrayI_mod
-! implicit none
-!
-! integer, parameter :: dimx = 10
-! integer, parameter :: dimy = 10
-!
-! integer, dimension(dimx, dimy) :: my_array
-!
-! integer :: x, y
-! logical :: flag
-!
-! type(DebugCheckArrayI) :: db
-!
-! do y = 1, dimy
-! do x = 1, dimx
-! my_array(x,y) = x * y
-! enddo
-! enddo
-!
-! call createDebugCheckArrayI(db, my_array, dimx*dimy, "my_array")
-!
-! ! .. do something
-!
-! write(*,*) testDebugCheckArrayI(db, my_array)
-!
-! ! .. do something bad
-!
-! my_array(3,5) = -3
-!
-! write(*,*) testDebugCheckArrayI(db, my_array)
-!
-! ! use optional fail_message
-! write(*,*) testDebugCheckArrayI(db, my_array, fail_message="location: main")
-!
-!
-! call destroyDebugCheckArrayI(db)
-!endprogram
diff --git a/source/KKRnano/source/DebugHelpers/DebugCheckArrayZ_mod.f90 b/source/KKRnano/source/DebugHelpers/DebugCheckArrayZ_mod.f90
deleted file mode 100644
index c076a3c2cb925f7a59ae36f7204ef60d4b9ca055..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/DebugHelpers/DebugCheckArrayZ_mod.f90
+++ /dev/null
@@ -1,105 +0,0 @@
-! Author: Elias Rabel
-module DebugCheckArrayZ_mod
- implicit none
- public
-
- type DebugCheckArrayZ
- private
- double complex, allocatable :: array_data(:)
- integer :: num_elements
- character(len=32) :: array_name
- endtype
-
- contains
-
- subroutine createDebugCheckArrayZ(self, array_to_check, num_elements, array_name)
- type(DebugCheckArrayZ), intent(inout) :: self
- double complex, intent(in) :: array_to_check(num_elements)
- integer, intent(in) :: num_elements
- character(len=*), intent(in) :: array_name
-
- integer :: ii
-
- allocate(self%array_data(num_elements))
-
- self%num_elements = num_elements
- self%array_name = array_name
-
- do ii = 1, num_elements
- self%array_data(ii) = array_to_check(ii)
- enddo ! ii
-
- endsubroutine
-
- logical function testDebugCheckArrayZ(self, array_to_check, fail_message)
- type(DebugCheckArrayZ), intent(in) :: self
- double complex, intent(in) :: array_to_check(*) ! accept any array
- character(len=*), intent(in), optional :: fail_message
-
- integer :: ii
-
- testDebugCheckArrayZ = .false.
-
- do ii = 1, self%num_elements
- if (self%array_data(ii) /= array_to_check(ii)) then
- write(*,*) "testDebugCheckArrayZ: Arrays do not match. Element ", ii
- if (present(fail_message)) then
- write(*,*) self%array_name, fail_message
- else
- write(*,*) self%array_name
- endif
- return
- endif
- enddo ! ii
-
- testDebugCheckArrayZ = .true.
-
- endfunction
-
- elemental subroutine destroyDebugCheckArrayZ(self)
- type(DebugCheckArrayZ), intent(inout) :: self
- integer :: ist
- deallocate(self%array_data, stat=ist) ! ignore status
- endsubroutine ! destroy
-
-endmodule
-
-
-!program TryDebugCheckArrayZ
-! use DebugCheckArrayZ_mod
-! implicit none
-!
-! integer, parameter :: dimx = 10
-! integer, parameter :: dimy = 10
-!
-! double complex, dimension(dimx, dimy) :: my_array
-!
-! integer :: x, y
-! logical :: flag
-!
-! type(DebugCheckArrayZ) :: db
-!
-! do y = 1, dimy
-! do x = 1, dimx
-! my_array(x,y) = x * y
-! enddo
-! enddo
-!
-! call createDebugCheckArrayZ(db, my_array, dimx*dimy, "my_array")
-!
-! ! .. do something
-!
-! write(*,*) testDebugCheckArrayZ(db, my_array)
-!
-! ! .. do something bad
-!
-! my_array(3,5) = -3
-!
-! write(*,*) testDebugCheckArrayZ(db, my_array)
-!
-! ! use optional fail_message
-! write(*,*) testDebugCheckArrayZ(db, my_array, fail_message="location: main")
-!
-!
-! call destroyDebugCheckArrayZ(db)
-!endprogram
diff --git a/source/KKRnano/source/DebugHelpers/arraytest2_mod.F90 b/source/KKRnano/source/DebugHelpers/arraytest2_mod.F90
index 05ab311940925d14f45354a0cb4e7c3412493abc..d6931220049c23af25f6bc6e3e35d56b7c39a447 100755
--- a/source/KKRnano/source/DebugHelpers/arraytest2_mod.F90
+++ b/source/KKRnano/source/DebugHelpers/arraytest2_mod.F90
@@ -13,10 +13,6 @@ module arraytest2_mod
module procedure ztest2d
module procedure ztest3d
module procedure ztest4d
-
- !module procedure itest1d
-
- ! repeat until 4d
endinterface
contains
@@ -93,7 +89,7 @@ module arraytest2_mod
double precision, intent(in) :: array(*)
integer, intent(in) :: length
- double precision, external :: DNRM2
+ double precision, external :: DNRM2 ! from LAPACK
! print norm and average
write(unit=str, fmt='(a7,i4,x,a16,x,e16.9,x,e16.9)') &
@@ -106,12 +102,11 @@ module arraytest2_mod
double complex, intent(in) :: array(*)
integer, intent(in) :: length
- double precision, external :: DZNRM2
+ double precision, external :: DZNRM2 ! from LAPACK
! print norm and average
write(unit=str, fmt='(a7,i4,x,a16,x,e12.5,x,e12.5,x,e12.5)') &
"DEBUG: ", nr, msg, DZNRM2(length, array, 1), sum(array(1:length))/length
-
endfunction
endmodule
diff --git a/source/KKRnano/source/IterativeSolver/KKRmat_mod.F90 b/source/KKRnano/source/IterativeSolver/KKRmat_mod.F90
index 785b690e2b5b8cf63f30bd8dd54ffea237182ba2..6cabb140dd7bb928e4e5995f9377d20841cc8a97 100644
--- a/source/KKRnano/source/IterativeSolver/KKRmat_mod.F90
+++ b/source/KKRnano/source/IterativeSolver/KKRmat_mod.F90
@@ -219,6 +219,11 @@ module KKRmat_mod
use fillKKRMatrix_mod, only: dump
use IterativeSolver_mod, only: IterativeSolver, solve
use DirectSolver_mod, only: DirectSolver, solve
+#ifdef has_tfQMRgpu
+ use tfqmrgpu, only: tfqmrgpu_bsrsv_complete ! all-in-one GPU solver interface for rapid integration
+ use SolverStats_mod, only: reduce
+ use TimerMpi_mod, only: startTimer, stopTimer
+#endif
use SparseMatrixDescription_mod, only: dump
use InitialGuess_mod, only: InitialGuess, load, store
use KKROperator_mod, only: KKROperator
@@ -257,6 +262,10 @@ module KKRmat_mod
double complex, allocatable :: dPdE_local(:,:,:), gllke_x(:,:), dgde(:,:), MinvdMdE(:,:,:), TinvMinvdMdE(:,:,:) ! LLY
double complex :: tracek ! LLY
+#ifdef has_tfQMRgpu
+ integer (kind=4) :: o, ierr, iterations, lda
+ real (kind=8) :: residual
+#endif
integer :: num_trunc_atoms, lmsd, lm1, idx_lly, i1
double complex :: cfctorinv
@@ -383,10 +392,38 @@ module KKRmat_mod
! store the initial guess
call store(iguess_data, op%mat_X, ik=ikpoint, is=ispin, ie=ienergy)
+ case (5) ! GPU solver
+
+#ifdef has_tfQMRgpu
+
+ o=0
+ ierr=0
+
+ iterations = 2000
+ residual = iterative_solver%qmrbound
+ lda = size(op%mat_A, 1)
+ call startTimer(kernel_timer)
+ ! write(*,*) "Written by us: ", size(op%bsr_X%ColIndex)
+ call tfqmrgpu_bsrsv_complete(op%bsr_A%nRows, lda, &
+ op%bsr_A%RowStart, op%bsr_A%ColIndex, op%mat_A(:,:,:,0), 't', & !! A (in)
+ op%bsr_X%RowStart, op%bsr_X%ColIndex, op%mat_X, 't', & !! X (out)
+ op%bsr_B%RowStart, op%bsr_B%ColIndex, op%mat_B, 't', & !! B (in)
+ iterations, residual, o, ierr)
+ call stopTimer(kernel_timer)
+ call reduce(iterative_solver%stats, iterations, residual, 0_8)
+
+#else
+ warn(6, "GPU solver needs -D has_tfQMRgpu (Problem is not solved) solver_type ="+solver_type)
+#endif
+
case default
warn(6, "No solver selected! Problem is not solved, solver_type ="+solver_type)
endselect ! solver_type
+ !call dump(op%mat_X, "solution_form.dat", formatted=.true.)
+ !call dump(op%mat_B, "rhs_form.dat", formatted=.true.)
+ !stop __FILE__
+
TESTARRAYLOG(3, op%mat_B)
TESTARRAYLOG(3, op%mat_X)
! RESULT: mat_X
diff --git a/source/KKRnano/source/IterativeSolver/fillKKRMatrix_mod.F90 b/source/KKRnano/source/IterativeSolver/fillKKRMatrix_mod.F90
index 745f05f02eacdd1fba5e36ca513a27659a70cc15..88ea971c0eda163bc5f8e31b8ed227acd3fd7c2e 100644
--- a/source/KKRnano/source/IterativeSolver/fillKKRMatrix_mod.F90
+++ b/source/KKRnano/source/IterativeSolver/fillKKRMatrix_mod.F90
@@ -32,7 +32,7 @@ module fillKKRMatrix_mod
type(SparseMatrixDescription), intent(out) :: bsr_X
integer(kind=1), intent(in) :: lmax_a(:,:) !< lmax of each interaction dim(naez_trc,num_local_atoms), -1: truncated
- integer, parameter :: GROUPING = 0 ! -1:never, 0:auto, 1:always
+ integer, parameter :: GROUPING = -1 ! -1:never, 0:auto, 1:always
integer :: iRow, jCol, Xind, nnzb, group
nnzb = count(lmax_a >= 0) ! number of non-zero blocks in X
@@ -46,7 +46,7 @@ module fillKKRMatrix_mod
endif
if (group > 0) then
-
+ !write(*,*) "we are in group > 0"
call create(bsr_X, nRows=size(lmax_a, 1), nnzb=size(lmax_a, 1), nCols=1)
! generate BSR descriptor of a flat structure, fuse RHS atoms into rectangular blocks
diff --git a/source/KKRnano/source/KKRnano.F90 b/source/KKRnano/source/KKRnano.F90
index e498678a0c9cfe31bbed4ab4b83bda234eb8e8f3..4118a7ec29be4448e5e263f96714714d35ff7194 100644
--- a/source/KKRnano/source/KKRnano.F90
+++ b/source/KKRnano/source/KKRnano.F90
@@ -268,7 +268,7 @@ program KKRnano
enddo ! ila
! Core relaxation - only mastergroup needs results
- if (mp%isInMasterGroup) then
+ if (mp%isInMasterGroup.and.params%npol /= 0) then
! Not threadsafe: intcor, intin, intout have a save statement
ebot = emesh%E1; if (any(params%npntsemi > 0)) ebot = emesh%EBOTSEMI
!!!$omp parallel do private(ila, atomdata)
diff --git a/source/KKRnano/source/Makefile b/source/KKRnano/source/Makefile
index 05f24378b49a2573248c06bd1cc8a685956098c8..759599018256f3db8ce4be073e6212a3ee2950a6 100644
--- a/source/KKRnano/source/Makefile
+++ b/source/KKRnano/source/Makefile
@@ -10,13 +10,26 @@ SMP ?= none
PROGRAM = kkr.exe
# Path to put object files and module files
-BUILDDIR = $(HOME)/build
+BUILDDIR = ./build
+
+EXTRA_FLAGS ?=
+
+### can we make use of the tfQMRgpu library?
+tfQMRgpu ?= no
+ifeq ($(tfQMRgpu),yes)
+ EXTRA_FLAGS += -D has_tfQMRgpu
+ TFQMRGPU_PATH = $(HOME)/tfQMRgpu
+endif
+
-EXTRA_FLAGS =
FC90FLAGS =
FCFLAGS =
PPFLAGS =
PPFLAGS += -D USE_VOROWEIGHTS
+ifeq ($(TYPE),debug)
+ PPFLAGS += -D DEBUG
+endif
+# PPFLAGS += -D NDEBUG
# PPFLAGS += -D BENCHMARK_tfQMR
# PPFLAGS += -D EXPORT_tfQMR_PROBLEM
@@ -24,7 +37,6 @@ PPFLAGS += -D USE_VOROWEIGHTS
# PPFLAGS += -D TRANSPOSE_TO_ROW_MAJOR
### TRANSPOSE_TO_ROW_MAJOR seems to work, however, there was a bug in col_norms about the non-linearity of DZNRM2, so we have to see which references went wrong
#PPFLAGS += -D SUPERCELL_ELECTROSTATICS=8
-# -D NDEBUG
LDFLAGS =
# ========= IFF Workstations ============
@@ -33,9 +45,9 @@ ifeq ($(PLATFORM),ifort)
FC = mpiifort -warn all
FC90 = mpiifort -warn all
# -module <path> specifies where to put .mod files
- ifeq ($(SMP),openmp)
- FCFLAGS += -qopenmp
- endif
+ ifeq ($(SMP),openmp)
+ FCFLAGS += -qopenmp
+ endif
FCFLAGS += -module $(BUILDDIR)
FCFLAGS += -I $(BUILDDIR)
# PPFLAGS += -D TASKLOCAL_FILES
@@ -53,7 +65,7 @@ ifeq ($(PLATFORM),ifort)
FCFLAGS += -O0 -g -check bounds -traceback -debug all -check all
PPFLAGS += -D USE_MTRADII -D USE_OLD_MESH -D NOLOGGING
else ifeq ($(TYPE),voronoi_mesh)
- FCFLAGS += -O2 -xHost
+ FCFLAGS += -O2
PPFLAGS += -D NOLOGGING -D USE_OLD_MESH
else ifeq ($(TYPE),voronoi_mesh_debug)
FCFLAGS += -O0 -g -check bounds -traceback -debug all -check all -fpe1
@@ -64,9 +76,8 @@ ifeq ($(PLATFORM),ifort)
else ifeq ($(TYPE),voronoi_mesh_print_mtradii)
FCFLAGS += -O0 -g
PPFLAGS += -D NOLOGGING -D USE_OLD_MESH -D PRINT_MTRADII
-
else
- FCFLAGS += -O2 -xHost
+ FCFLAGS += -O2
PPFLAGS += -D NOLOGGING
endif
endif
@@ -91,12 +102,14 @@ ifeq ($(PLATFORM),gfortran)
FC90FLAGS = -ffree-line-length-0
PPFLAGS += -D NOLOGGING
# FCFLAGS += -D TASKLOCAL_FILES ### breaks when TASKLOCAL_FILES is used
- LDFLAGS += -L /usr/local/atlas/lib -llapack -lf77blas -lcblas -latlas
+# LDFLAGS += -L /usr/local/atlas/lib -llapack -latlas
+ LDFLAGS += -L${MKLROOT}/lib/intel64 -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -liomp5 ###-lpthread
+# # LDFLAGS += -lgfortran
+ ### -lf77blas -lcblas -latlas
endif
# ================== JURECA ======================
-# optimal setup on one node seems to be 8MPI/3OMP for 64 atoms
# The following software stages were tested and work:
# module --force purge
# module use /usr/local/software/jureca/OtherStages
@@ -112,21 +125,21 @@ ifeq ($(PLATFORM),jureca)
FCFLAGS += -module $(BUILDDIR)
FCFLAGS += -I $(BUILDDIR)
# PPFLAGS += -D TASKLOCAL_FILES
- FCFLAGS += -g
+ FCFLAGS += -g -march=core-avx2
LDFLAGS += -g -L${MKLROOT}/lib/intel64 -lmkl_intel_lp64 -lmkl_intel_thread -lmkl_core -liomp5 -lpthread -lm -ldl
ifeq ($(TYPE),debug_light)
FCFLAGS += -O0 -g
else ifeq ($(TYPE),debug)
FCFLAGS += -O0 -g -check bounds -traceback -debug all -check all -fpe1
else ifeq ($(TYPE),mtradii)
- FCFLAGS += -O2 -xHost
+ FCFLAGS += -O2
PPFLAGS += -D USE_MTRADII
PPFLAGS += -D NOLOGGING -D USE_OLD_MESH
else ifeq ($(TYPE),debug_mtradii)
FCFLAGS += -O0 -g -check bounds -traceback -debug all -check all
PPFLAGS += -D USE_MTRADII
else ifeq ($(TYPE),voronoi_mesh)
- FCFLAGS += -O2 -xHost
+ FCFLAGS += -O2
PPFLAGS += -D NOLOGGING -D USE_OLD_MESH
else ifeq ($(TYPE),voronoi_mesh_debug)
FCFLAGS += -O0 -g -check bounds -traceback -debug all -check all -fpe1
@@ -135,7 +148,7 @@ ifeq ($(PLATFORM),jureca)
FCFLAGS += -O0 -g
PPFLAGS += -D NOLOGGING -D USE_OLD_MESH
else
- FCFLAGS += -O2 -xHost
+ FCFLAGS += -O2
PPFLAGS += -D NOLOGGING
endif
endif
@@ -184,14 +197,14 @@ ifeq ($(PLATFORM),jureca_knl)
PPFLAGS += -D NOLOGGING
endif
endif
-# ================== HAZEL HEN ======================
+# ================== HAWK ===========================
# Usage of Intel compiler and Intel MKL seems to give best results:
# module swap PrgEnv-cray PrgEnv-intel
# module unload cray-libsci
# Remarks: - Bad GGA performance -> Use LDA!
# - Home directory slow -> Use Workspace (see HLRS wiki)
# - If 'seg 0' error occurs, add 'module unload craype-hugepages16M' to job file
-ifeq ($(PLATFORM),hazelhen)
+ifeq ($(PLATFORM),hawk)
FC = ftn
FC90 = ftn
# -module <path> specifies where to put .mod files
@@ -307,7 +320,7 @@ PPFLAGS = -WF,-DUSE_VOROWEIGHTS -WF,-DCOMPUTE_tref_LOCALLY -WF,-DNOLOGGING
ifeq ($(SMP),openmp)
FCFLAGS += -qsmp=omp
- PPFLAGS += -WF,-DCPP_hybrid
+ PPFLAGS += -WF,-DCPP_hybrid
endif
#ESSL
@@ -317,16 +330,16 @@ endif
LDFLAGS = -L/bgsys/local/lib -lesslsmpbg -L/opt/ibmcmp/xlsmp/3.1/bglib64 -lxlsmp -L/bgsys/local/fftw3/3.3.2/fftw_g/lib/ -lfftw3
ifeq ($(TYPE),debug)
- FCFLAGS += -q64 -O0 -qstrict -g -qnosave -C -qinitauto=7FF7FFFF -WF,-DDEBUG1
+ FCFLAGS += -q64 -O0 -qstrict -g -qnosave -C -qinitauto=7FF7FFFF -WF,-DDEBUG1
else ifeq ($(TYPE),scorep)
- FC = scorep mpixlf77_r
- FC90 = scorep mpixlf90_r
- FCFLAGS += -q64 -O3 -qstrict
+ FC = scorep mpixlf77_r
+ FC90 = scorep mpixlf90_r
+ FCFLAGS += -q64 -O3 -qstrict
else ifeq ($(TYPE),voronoi_mesh)
- FCFLAGS += -q64 -O3 -qstrict
- PPFLAGS += -WF,-DUSE_OLD_MESH
+ FCFLAGS += -q64 -O3 -qstrict
+ PPFLAGS += -WF,-DUSE_OLD_MESH
else
- FCFLAGS += -q64 -O3 -qstrict
+ FCFLAGS += -q64 -O3 -qstrict
endif
#ifeq ($(USETOOL),scalasca)
@@ -368,18 +381,33 @@ SRCS = $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.f))
SRCS90 = $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.f90))
SRCSFPP = $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.F))
SRCS90FPP = $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.F90))
+SRCS95TMPL = $(foreach DIR,$(DIRS),$(wildcard $(DIR)/*.F95))
+
+
+OBJS=
+
+ifeq ($(tfQMRgpu),yes)
+ LDFLAGS += -L$(TFQMRGPU_PATH)/lib64 -ltfQMRgpu_Fortran -ltfQMRgpu
+ OBJS += tfQMRgpu_mod.o
+endif
+
+
+LINKER= $(FC90)
+
# notdir extracts only filename
-OBJS = $(notdir ${SRCS:.f=.o})
+OBJS += $(notdir ${SRCS:.f=.o})
OBJS += $(notdir ${SRCS90:.f90=.o})
OBJS += $(notdir ${SRCSFPP:.F=.o})
OBJS += $(notdir ${SRCS90FPP:.F90=.o})
+OBJS += $(notdir ${SRCS95TMPL:.F95=.o})
+
.PHONY: all
all: $(PROGRAM)
$(PROGRAM): $(OBJS)
- $(FC90) $(FCFLAGS) -o $(PROGRAM) $(addprefix $(BUILDDIR)/,$(OBJS)) $(LDFLAGS)
+ $(LINKER) -o $(PROGRAM) $(addprefix $(BUILDDIR)/,$(OBJS)) $(LDFLAGS)
%.o: %.f
$(FC) $(FCFLAGS) $(EXTRA_FLAGS) -c $< -o $(BUILDDIR)/$@
@@ -387,17 +415,28 @@ $(PROGRAM): $(OBJS)
%.o: %.f90
$(FC90) $(FCFLAGS) $(EXTRA_FLAGS) $(FC90FLAGS) -c $< -o $(BUILDDIR)/$@
-%.o: %.f95
- $(FC90) $(FCFLAGS) $(EXTRA_FLAGS) $(FC90FLAGS) -c $< -o $(BUILDDIR)/$@
-
%.o: %.F
$(FC) $(FCFLAGS) $(EXTRA_FLAGS) $(PPFLAGS) $(PPFLAGS) -c $< -o $(BUILDDIR)/$@
%.o: %.F90
$(FC90) $(FCFLAGS) $(EXTRA_FLAGS) $(FC90FLAGS) $(PPFLAGS) -c $< -o $(BUILDDIR)/$@
+ifeq ($(tfQMRgpu),yes)
+# add a target tfQMRgpu
+tfQMRgpu: $(TFQMRGPU_PATH)/example/tfqmrgpu_Fortran_example.F90
+ $(FC90) -I $(TFQMRGPU_PATH)/tfQMRgpu/include $(FCFLAGS) $(EXTRA_FLAGS) \
+ $(FC90FLAGS) $(PPFLAGS) -c $< -o $(BUILDDIR)/tfQMRgpu_mod.o
+endif
+
+
+### Fortran-templates:
%.o: %.F95
- $(FC90) $(FCFLAGS) $(EXTRA_FLAGS) $(FC90FLAGS) $(PPFLAGS) -c $< -o $(BUILDDIR)/$@
+ sed -e 's/_TYPE/D/' $< > $(BUILDDIR)/$*.F90
+ sed -e 's/_TYPE/C/' $< >> $(BUILDDIR)/$*.F90
+ sed -e 's/_TYPE/Z/' $< >> $(BUILDDIR)/$*.F90
+ sed -e 's/_TYPE/I/' $< >> $(BUILDDIR)/$*.F90
+ $(FC90) $(FCFLAGS) $(EXTRA_FLAGS) $(FC90FLAGS) $(PPFLAGS) -c $(BUILDDIR)/$*.F90 -o $(BUILDDIR)/$@
+
.PHONY: clean
clean:
rm -f $(BUILDDIR)/*.o
@@ -407,45 +446,50 @@ clean:
.PHONY: test
test:
- @echo $(SRCS)
- @echo $(SRCS90)
@echo $(OBJS)
@echo $(VPATH)
+ @echo $(SRCS90FPP)
.PHONY: depend
depend:
$(SRCS90)
makedepend
+ifeq ($(tfQMRgpu),yes)
+ # manually add a dependency
+ KKRmat_mod.o: tfQMRgpu_mod.o
+endif
+
+
#======================== Module dependencies ========================================
KKRnano.o: Logging_mod.o KKRzero_mod.o PotentialConverter_mod.o KKRnanoParallel_mod.o BasisAtom_mod.o AtomicCore_mod.o RadialMeshData_mod.o main2_aux_mod.o ScatteringCalculation_mod.o Main2Arrays_mod.o KKRnano_Comm_mod.o ProcessKKRresults_mod.o InputParams_mod.o EBalanceHandler_mod.o LDAUData_mod.o TimerMpi_mod.o EnergyMesh_mod.o DimParams_mod.o CalculationData_mod.o
TruncationZone_mod.o: Main2Arrays_mod.o
-KKRmat_mod.o: ExchangeTable_mod.o two_sided_commZ_mod.o arraytest2_mod.o Logging_mod.o TimerMpi_mod.o KKROperator_mod.o one_sided_commZ_mod.o ClusterInfo_mod.o IterativeSolver_mod.o jij_calc_mod.o Truncation_mod.o SparseMatrixDescription_mod.o BCPOperator_mod.o SolverStats_mod.o InitialGuess_mod.o fillKKRMatrix_mod.o DirectSolver_mod.o
+KKRmat_mod.o: ExchangeTable_mod.o two_sided_comm_mod.o arraytest2_mod.o Logging_mod.o TimerMpi_mod.o KKROperator_mod.o one_sided_comm_mod.o ClusterInfo_mod.o IterativeSolver_mod.o jij_calc_mod.o Truncation_mod.o SparseMatrixDescription_mod.o BCPOperator_mod.o SolverStats_mod.o InitialGuess_mod.o fillKKRMatrix_mod.o DirectSolver_mod.o
ProcessKKRresults_mod.o: arraytest2_mod.o KKRnanoParallel_mod.o AtomicForce_mod.o Logging_mod.o Lloyds_formula_mod.o wrappers_mod.o brydbm_new_com_mod.o Main2Arrays_mod.o ShapefunData_mod.o EnergyResults_mod.o LDAUData_mod.o ShapeGauntCoefficients_mod.o GauntCoefficients_mod.o CalculationData_mod.o muffin_tin_zero_mod.o RadialMeshData_mod.o MadelungPotential_mod.o broyden_kkr_mod.o EnergyMesh_mod.o BasisAtom_mod.o DensityResults_mod.o Lloyd0_new_mod.o KKRresults_mod.o InputParams_mod.o TimerMpi_mod.o DimParams_mod.o BroydenData_mod.o NearField_calc_mod.o debug_morgan_mod.o total_energy_mod.o
NearField_kkr_mod.o: Constants_mod.o
NearField_calc_mod.o: RadialMeshData_mod.o NearField_com_mod.o BasisAtom_mod.o CalculationData_mod.o
NearField_mod.o: Harmonics_mod.o MadelungCalculator_mod.o Constants_mod.o NearField_kkr_mod.o
-KKRnano_Comm_mod.o: KKRnanoParallel_mod.o jij_calc_mod.o comm_patternsD_mod.o comm_patternsZ_mod.o comm_patternsC_mod.o Exceptions_mod.o
+KKRnano_Comm_mod.o: KKRnanoParallel_mod.o jij_calc_mod.o comm_patterns_mod.o Exceptions_mod.o
InputParams_mod.o: ConfigReader_mod.o
PolygonFaces_mod.o: Constants_mod.o
ShapeGeometryHelpers_mod.o: Exceptions_mod.o Constants_mod.o
ShapeStandardMesh_mod.o: Exceptions_mod.o Constants_mod.o
wrappers_mod.o: Warnings_mod.o ValenceDensity_mod.o SingleSite_mod.o BasisAtom_mod.o RadialMeshData_mod.o ShapefunData_mod.o EnergyMesh_mod.o LDAUData_mod.o ShapeGauntCoefficients_mod.o GauntCoefficients_mod.o NonCollinearMagnetism_mod.o ##AtomicCore_mod.o
-BCPOperator_mod.o: ClusterInfo_mod.o Exceptions_mod.o
+BCPOperator_mod.o: ClusterInfo_mod.o Exceptions_mod.o
CalculationData_mod.o: Exceptions_mod.o ExchangeTable_mod.o KKRnanoParallel_mod.o JelliumPotentials_mod.o LatticeVectors_mod.o TruncationZone_mod.o Main2Arrays_mod.o EnergyResults_mod.o LDAUData_mod.o ShapeGauntCoefficients_mod.o GauntCoefficients_mod.o InitialGuess_mod.o MadelungCalculator_mod.o RadialMeshData_mod.o ConstructShapes_mod.o InterpolateBasisAtom_mod.o BasisAtom_mod.o ShapefunData_mod.o DensityResults_mod.o KKRresults_mod.o InputParams_mod.o RefCluster_mod.o DimParams_mod.o ClusterInfo_mod.o BroydenData_mod.o JijData_mod.o Truncation_mod.o ChebMeshData_mod.o NonCollinearMagnetismData_mod.o
-NearField_com_mod.o: Logging_mod.o one_sided_commD_mod.o NearField_mod.o MadelungCalculator_mod.o NearField_kkr_mod.o
+NearField_com_mod.o: Logging_mod.o one_sided_comm_mod.o NearField_mod.o MadelungCalculator_mod.o NearField_kkr_mod.o
ShapeIntegrationHelpers_mod.o: Constants_mod.o
ConstructShapes_mod.o: RefCluster_mod.o ShapefunData_mod.o Voronoi_mod.o ShapeFunctions_mod.o LatticeVectors_mod.o
EnergyMesh_mod.o: EnergyMeshHelpers_mod.o
InterpolateBasisAtom_mod.o: RadialMeshData_mod.o BasisAtom_mod.o PotentialData_mod.o AtomicCoreData_mod.o
SingleSiteRef_mod.o: Harmonics_mod.o kkr_helpers_mod.o SingleSiteHelpers_mod.o Exceptions_mod.o
-IterativeSolver_mod.o: tfQMR_mod.o SolverStats_mod.o TimerMpi_mod.o
+IterativeSolver_mod.o: tfQMR_mod.o SolverStats_mod.o TimerMpi_mod.o
kloopz1_mod.o: KKROperator_mod.o ClusterInfo_mod.o BCPOperator_mod.o KKRmat_mod.o jij_calc_mod.o IterativeSolver_mod.o InitialGuess_mod.o Constants_mod.o TimerMpi_mod.o
-ShapeCriticalPoints_mod.o: Constants_mod.o ShapeGeometryHelpers_mod.o PolygonFaces_mod.o
+ShapeCriticalPoints_mod.o: Constants_mod.o ShapeGeometryHelpers_mod.o PolygonFaces_mod.o
MadelungPotential_mod.o: BasisAtom_mod.o MadelungCalculator_mod.o RadialMeshData_mod.o DensityResults_mod.o EnergyResults_mod.o CalculationData_mod.o
EBalanceHandler_mod.o: KKRnanoParallel_mod.o Exceptions_mod.o
-ShapeIntegration_mod.o: ShapeIntegrationHelpers_mod.o Constants_mod.o PolygonFaces_mod.o
+ShapeIntegration_mod.o: ShapeIntegrationHelpers_mod.o Constants_mod.o PolygonFaces_mod.o
BasisAtom_mod.o: Exceptions_mod.o RadialMeshData_mod.o ShapefunData_mod.o PotentialData_mod.o AtomicCoreData_mod.o ChebMeshData_mod.o
tfQMR_mod.o: Logging_mod.o SolverStats_mod.o KKROperator_mod.o BCPOperator_mod.o TimerMpi_mod.o
KKRresults_mod.o: DimParams_mod.o
@@ -459,8 +503,8 @@ ShapeFunctions_mod.o: PolygonFaces_mod.o ShapeCriticalPoints_mod.o Constants_mod
ConfigReader_mod.o: ConfigReaderDictionary_mod.o
KKROperator_mod.o: Truncation_mod.o ClusterInfo_mod.o fillKKRMatrix_mod.o SparseMatrixDescription_mod.o bsrmm_mod.o
Lloyd0_new_mod.o: BasisAtom_mod.o RadialMeshData_mod.o ShapefunData_mod.o EnergyMesh_mod.o LDAUData_mod.o GauntCoefficients_mod.o ValenceDensity_mod.o
-ClusterInfo_mod.o: Statistics_mod.o TruncationZone_mod.o RefCluster_mod.o two_sided_commI_mod.o ExchangeTable_mod.o
-ScatteringCalculation_mod.o: KKRnanoParallel_mod.o one_sided_commD_mod.o Constants_mod.o SingleSiteRef_mod.o arraytest2_mod.o Logging_mod.o InputParams_mod.o TruncationZone_mod.o wrappers_mod.o Main2Arrays_mod.o KKRnano_Comm_mod.o jij_calc_mod.o BCPOperator_mod.o LDAUData_mod.o one_sided_commZ_mod.o GauntCoefficients_mod.o InitialGuess_mod.o CalculationData_mod.o EBalanceHandler_mod.o EnergyMesh_mod.o KKROperator_mod.o BasisAtom_mod.o KKRresults_mod.o IterativeSolver_mod.o RefCluster_mod.o TimerMpi_mod.o DimParams_mod.o kloopz1_mod.o ClusterInfo_mod.o JijData_mod.o Truncation_mod.o two_sided_commD_mod.o ChebMeshData_mod.o NonCollinearMagnetism_mod.o
+ClusterInfo_mod.o: Statistics_mod.o TruncationZone_mod.o RefCluster_mod.o two_sided_comm_mod.o ExchangeTable_mod.o
+ScatteringCalculation_mod.o: KKRnanoParallel_mod.o Constants_mod.o SingleSiteRef_mod.o arraytest2_mod.o Logging_mod.o InputParams_mod.o TruncationZone_mod.o wrappers_mod.o Main2Arrays_mod.o KKRnano_Comm_mod.o jij_calc_mod.o BCPOperator_mod.o LDAUData_mod.o one_sided_comm_mod.o GauntCoefficients_mod.o InitialGuess_mod.o CalculationData_mod.o EBalanceHandler_mod.o EnergyMesh_mod.o KKROperator_mod.o BasisAtom_mod.o KKRresults_mod.o IterativeSolver_mod.o RefCluster_mod.o TimerMpi_mod.o DimParams_mod.o kloopz1_mod.o ClusterInfo_mod.o JijData_mod.o Truncation_mod.o two_sided_comm_mod.o ChebMeshData_mod.o NonCollinearMagnetism_mod.o
total_energy_mod.o: Quadrature_mod.o BasisAtom_mod.o RadialMeshData_mod.o ShapefunData_mod.o ShapeGauntCoefficients_mod.o
vxcgga.o: XCFunctionals_mod.o
KKRzero_mod.o: Exceptions_mod.o BrillouinZoneMesh_mod.o PositionReader_mod.o MadelungCalculator_mod.o Startb1_mod.o EnergyMesh_mod.o EnergyMeshHelpers_mod.o Lattice_mod.o BrillouinZone_mod.o ConfigReader_mod.o ConfigReaderDictionary_mod.o InputParams_mod.o Main2Arrays_mod.o DimParams_mod.o BasisAtom_mod.o ShapefunData_mod.o PotentialData_mod.o AtomicCoreData_mod.o RadialMeshData_mod.o ShapefunData_mod.o read_formatted_mod.o read_formatted_shapefun_mod.o ldauinfo_read.o ldaustart.o
@@ -494,9 +538,6 @@ EnergyMeshHelpers_mod.o: GaussWeights_mod.o Constants_mod.o
jij_calc_mod.o: Sorting_mod.o
PotentialConverter_mod.o: DimParams_mod.o BasisAtom_mod.o RadialMeshData_mod.o PotentialData_mod.o
Startb1_mod.o: RadialMeshData_mod.o BasisAtom_mod.o read_formatted_mod.o read_formatted_shapefun_mod.o InputParams_mod.o ChebMeshData_mod.o
-one_sided_commZ_mod.o: ChunkIndex_mod.o
-one_sided_commI_mod.o: ChunkIndex_mod.o
-one_sided_commD_mod.o: ChunkIndex_mod.o
RadialMeshData_mod.o: Exceptions_mod.o
read_formatted_mod.o: Exceptions_mod.o
BrillouinZone_mod.o: Exceptions_mod.o BrillouinZoneMesh_mod.o
@@ -513,15 +554,15 @@ AtomicCore_mod.o: Exceptions_mod.o Quadrature_mod.o Constants_mod.o
JelliumPotentials_mod.o: Exceptions_mod.o
DirectSolver_mod.o: Exceptions_mod.o KKROperator_mod.o fillKKRMatrix_mod.o
ExchangeTable_mod.o: ChunkIndex_mod.o
-two_sided_commZ_mod.o: ExchangeTable_mod.o
-two_sided_commD_mod.o: ExchangeTable_mod.o
-two_sided_commI_mod.o: ExchangeTable_mod.o
+one_sided_comm_mod.o: ChunkIndex_mod.o
+two_sided_comm_mod.o: ExchangeTable_mod.o
LocalAtomData_mod.o: Exceptions_mod.o RadialMeshData_mod.o ShapefunData_mod.o BasisAtom_mod.o LDAUData_mod.o JijData_mod.o RefCluster_mod.o MadelungCalculator_mod.o DensityResults_mod.o EnergyResults_mod.o KKRresults_mod.o
bsrmm_mod.o: CacheOverlap_mod.o
CacheOverlap_mod.o:
ChebMeshData_mod.o: InputParams_mod.o RadialMeshData_mod.o
Truncation_mod.o: Logging_mod.o Exceptions_mod.o TruncationZone_mod.o
-NonCollinearMagnetism_mod.o: RadialMeshData_mod.o ChebMeshData_mod.o
+NonCollinearMagnetism_mod.o: RadialMeshData_mod.o ChebMeshData_mod.o read_formatted_shapefun_mod.o
NonCollinearMagnetismData_mod.o: Exceptions_mod.o
+vintras_new.o: SingleSiteHelpers_mod.o
# DO NOT DELETE
diff --git a/source/KKRnano/source/NonCollinearMagnetism_mod.F90 b/source/KKRnano/source/NonCollinearMagnetism_mod.F90
index fea34a3c32be41a9a1a5bb85c5482b96930e077f..aca2580fe50037e13b8d361ce68e6c7ad21f246f 100644
--- a/source/KKRnano/source/NonCollinearMagnetism_mod.F90
+++ b/source/KKRnano/source/NonCollinearMagnetism_mod.F90
@@ -12,7 +12,7 @@ module NonCollinearMagnetism_mod
!> ToDo: adopt coding style to real F90
!-------------------------------------------------------------------------------
use RadialMeshData_mod!, only:
-use ChebMeshData_mod!, only:
+use ChebMeshData_mod!, only
implicit none
private
@@ -22,2807 +22,2678 @@ public :: rotatematrix
contains
-SUBROUTINE drvbastrans(rc,crel,rrel,srrel,nrrel,irrel, &
- nlmax,nkmmax,nmuemax,nkmpmax,nkmax,linmax)
-! ********************************************************************
-! * *
-! * *
-! ********************************************************************
-IMPLICIT REAL*8(a-h,o-z)
+SUBROUTINE tmat_newsolver(ie,nspin,lmax,zat,socscale, &
+ ez,nsra,cleb,icleb,iend,ncheb,npan_tot, &
+ rpan_intervall,ipan_intervall, &
+ rnew,vinsnew,theta,phi,ipot, &
+ ! lly, &
+ lmpotd,irmd_new,TmatN,soc,enable_quad_prec) ! new input parameters
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-18 Time: 14:58:02
+
+IMPLICIT NONE
-COMPLEX*16, INTENT(IN OUT) :: rc(nkmmax,nkmmax)
-COMPLEX*16, INTENT(IN OUT) :: crel(nkmmax,nkmmax)
-COMPLEX*16, INTENT(IN OUT) :: rrel(nkmmax,nkmmax)
-COMPLEX*16, INTENT(IN OUT) :: srrel(2,2,nkmmax)
-INTEGER, INTENT(IN OUT) :: nrrel(2,nkmmax)
-INTEGER, INTENT(IN OUT) :: irrel(2,2,nkmmax)
-INTEGER, INTENT(IN) :: nlmax
-INTEGER, INTENT(IN) :: nkmmax
-INTEGER, INTENT(IN) :: nmuemax
-INTEGER, INTENT(IN) :: nkmpmax
-INTEGER, INTENT(IN) :: nkmax
-INTEGER, INTENT(IN) :: linmax
+INTEGER, INTENT(IN) :: ie
+INTEGER, INTENT(IN) :: nspin
+INTEGER, INTENT(IN) :: lmax
+DOUBLE PRECISION, INTENT(IN) :: zat
+DOUBLE PRECISION, INTENT(IN) :: socscale
+DOUBLE COMPLEX, INTENT(IN) :: ez(:)
+INTEGER, INTENT(IN) :: nsra
+DOUBLE PRECISION, INTENT(IN) :: cleb(:)
+INTEGER, INTENT(IN) :: icleb(:,:)
+INTEGER, INTENT(IN) :: iend
+INTEGER, INTENT(IN) :: ncheb
+INTEGER, INTENT(IN) :: npan_tot
+DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
+INTEGER, INTENT(IN) :: ipan_intervall(0:)
+DOUBLE PRECISION, INTENT(IN) :: rnew(:)
+DOUBLE PRECISION, INTENT(IN) :: vinsnew(:,:,:)
+DOUBLE PRECISION, INTENT(IN) :: theta
+DOUBLE PRECISION, INTENT(IN) :: phi
+INTEGER, INTENT(IN) :: ipot
+INTEGER, INTENT(IN) :: lmpotd
+INTEGER, INTENT(IN) :: irmd_new
+DOUBLE COMPLEX, INTENT(OUT) :: TmatN(:,:)
+LOGICAL, INTENT(IN) :: soc
+LOGICAL, INTENT(IN) :: enable_quad_prec
-!*** Start of declarations rewritten by SPAG
+INTEGER :: lmmaxd
+INTEGER :: lmmaxso
+INTEGER :: nrmaxd
-! Local variables
+DOUBLE COMPLEX eryd
-REAL*8 cgc(nkmpmax,2)
-INTEGER :: i,ikm1lin(linmax),ikm2lin(linmax),il,imue,iprint, &
- kaptab(nmuemax),ltab(nmuemax),mmax,nmuetab(nmuemax), nsollm(nlmax,nmuemax)
+DOUBLE PRECISION, PARAMETER :: cvlight=274.0720442D0
+DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
+DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
-!*** End of declarations rewritten by SPAG
-IF (nkmmax /= 2*nlmax**2) STOP ' Check NLMAX,NKMMAX in < DRVBASTRANS > '
-IF (nmuemax /= 2*nlmax) STOP ' Check NLMAX,NMUEMAX in < DRVBASTRANS > '
-IF (nkmpmax /= (nkmmax+2*nlmax)) &
- STOP ' Check NLMAX,NKMMAX,NKMPMAX in < DRVBASTRANS > '
-IF (nkmax /= 2*nlmax-1) STOP ' Check NLMAX,NKMAX in < DRVBASTRANS > '
-IF (linmax /= (2*nlmax*(2*nlmax-1))) &
- STOP ' Check NLMAX,LINMAX in < DRVBASTRANS > '
+DOUBLE COMPLEX, allocatable :: tmatll(:,:)
+DOUBLE COMPLEX, allocatable :: alpha(:,:)
+INTEGER :: ir,use_sratrick,nvec,lm1,irmdnew
+DOUBLE COMPLEX gmatprefactor
+DOUBLE PRECISION, allocatable :: vins(:,:,:)
+DOUBLE COMPLEX, allocatable :: vnspll0(:,:,:),vnspll1(:,:,:), vnspll(:,:,:)
+DOUBLE COMPLEX, allocatable :: hlk(:,:),jlk(:,:), hlk2(:,:),jlk2(:,:)
+DOUBLE COMPLEX, allocatable :: rll(:,:,:),ull(:,:,:)
+!DOUBLE COMPLEX, allocatable :: rllleft(:,:,:),sllleft(:,:,:) ! neded for D_ij calculation
+DOUBLE COMPLEX, allocatable :: tmatsph(:)! TMAT_OUT(:,:), tmat_out necessary for parallel ie loop
+DOUBLE COMPLEX, allocatable :: dtmatll(:,:),tmat0(:,:) ! LLY
+DOUBLE COMPLEX, allocatable :: alphall(:,:),dalphall(:,:),alpha0(:,:),aux(:,:) ! LLY
+!DOUBLE COMPLEX, allocatable :: alphasph(:)!, DTMAT_OUT(:,:,:), ! LLY
+INTEGER, allocatable :: jlk_index(:)
+! LLoyd:
+!INTEGER :: ideriv,signde ! LLY
+!DOUBLE COMPLEX :: tralpha ! LLY
+DOUBLE COMPLEX, allocatable :: ipiv(:) ! LLY
-iprint = 0
+lmmaxd = (lmax+1)**2
+lmmaxso=2*lmmaxd
+nrmaxd=irmd_new
-DO i = 1,nmuemax
- ltab(i) = i/2
- IF ( 2*ltab(i) == i ) THEN
- kaptab(i) = ltab(i)
- ELSE
- kaptab(i) = -ltab(i) - 1
- END IF
- nmuetab(i) = 2*ABS(kaptab(i))
-END DO
+allocate(tmatll(lmmaxso,lmmaxso))
+allocate(alpha(lmmaxso,lmmaxso))
+allocate(dtmatll(lmmaxso,lmmaxso))
+allocate(tmat0(lmmaxso,lmmaxso))
+allocate(alphall(lmmaxso,lmmaxso))
+allocate(dalphall(lmmaxso,lmmaxso))
+allocate(alpha0(lmmaxso,lmmaxso))
+allocate(aux(lmmaxso,lmmaxso))
+allocate(jlk_index(2*lmmaxso))
+allocate(ipiv(lmmaxso))
-DO il = 1,nlmax
- mmax = 2*il
- DO imue = 1,mmax
- IF ( (imue == 1) .OR. (imue == mmax) ) THEN
- nsollm(il,imue) = 1
- ELSE
- nsollm(il,imue) = 2
- END IF
+irmdnew= npan_tot*(ncheb+1)
+allocate(vins(irmdnew,lmpotd,nspin))
+vins=0D0
+DO lm1=1,lmpotd
+ DO ir=1,irmdnew
+ vins(ir,lm1,1)=vinsnew(ir,lm1,ipot)
+ vins(ir,lm1,nspin)=vinsnew(ir,lm1,ipot+nspin-1)
END DO
END DO
+!c set up the non-spherical ll' matrix for potential VLL'
+ IF (NSRA.EQ.2) THEN
+USE_SRATRICK=1
+ELSEIF (NSRA.EQ.1) THEN
+USE_SRATRICK=0
+ENDIF
+allocate(vnspll0(lmmaxso,lmmaxso,irmdnew))
+allocate(vnspll1(lmmaxso,lmmaxso,irmdnew))
+vnspll0=czero
+CALL vllmat(1,irmdnew,lmmaxd,lmmaxso,vnspll0,vins, &
+ cleb,icleb,iend,nspin,zat,rnew,use_sratrick)
-CALL ikmlin(iprint,nsollm,ikm1lin,ikm2lin,nlmax,nmuemax,linmax, nlmax)
+! initial allocate
+IF (nsra == 2) THEN
+ allocate(vnspll(2*lmmaxso,2*lmmaxso,irmdnew))
+ELSE
+ allocate(vnspll(lmmaxso,lmmaxso,irmdnew))
+END IF
-CALL calccgc(ltab,kaptab,nmuetab,cgc,nkmax,nmuemax,nkmpmax)
+allocate(hlk(1:4*(lmax+1),irmdnew))
+allocate(jlk(1:4*(lmax+1),irmdnew))
+allocate(hlk2(1:4*(lmax+1),irmdnew))
+allocate(jlk2(1:4*(lmax+1),irmdnew))
+allocate(tmatsph(2*(lmax+1)))
+allocate(rll(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(ull(nsra*lmmaxso,lmmaxso,irmdnew))
+!allocate(rllleft(nsra*lmmaxso,lmmaxso,irmdnew))
+!allocate(sllleft(nsra*lmmaxso,lmmaxso,irmdnew))
+!allocate(tmat_out(lmmaxso,lmmaxso))
-! ---------------------------- now calculate the transformation matrices
+ eryd = ez(ie)
+
+! contruct the spin-orbit coupling hamiltonian and add to potential
+ CALL spinorbit_ham(lmax,lmmaxd,vins,rnew, &
+ eryd,zat,cvlight,socscale,nspin,lmpotd, &
+ theta,phi,ipan_intervall,rpan_intervall, npan_tot,ncheb,irmdnew,nrmaxd, &
+ vnspll0,vnspll1,'1',soc)
+!c extend matrix for the SRA treatment
+ vnspll=czero
+ IF (nsra == 2) THEN
+ IF (use_sratrick == 0) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
+ ELSE IF (use_sratrick == 1) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
+ END IF
+ ELSE
+ vnspll=vnspll1
+ END IF
+
+!c calculate the source terms in the Lippmann-Schwinger equation
+!c these are spherical hankel and bessel functions
+ hlk=czero
+ jlk=czero
+ hlk2=czero
+ jlk2=czero
+ gmatprefactor=czero
+ CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
+ lmmaxso,1,jlk_index,hlk, &
+ jlk,hlk2,jlk2, gmatprefactor)
+!c using spherical potential as reference
+ IF (use_sratrick == 1) THEN
+ CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
+ rnew,vins,ncheb,npan_tot,rpan_intervall, &
+ jlk_index,hlk,jlk,hlk2, &
+ jlk2,gmatprefactor,tmatsph,use_sratrick,enable_quad_prec)
+ END IF
+
+!c calculate the tmat and wavefunctions
+ rll(:,:,:)=czero
+
+!c right solutions
+ tmatll=czero
+ CALL rll_global_solutions(rpan_intervall,rnew,vnspll, &
+ rll,ull,tmatll(:,:),ncheb, &
+ npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1),irmdnew, &
+ nsra,jlk_index,hlk,jlk, &
+ hlk2,jlk2,gmatprefactor,use_sratrick,alpha)
+! IF (nsra == 2) THEN
+! RLL(LMMAXSO+1:NVEC*LMMAXSO,:,:)=
+! + RLL(LMMAXSO+1:NVEC*LMMAXSO,:,:)/C
+! END IF
+!if(t_dtmatjij_at%calculate) then
-CALL strsmat(nlmax-1,cgc,srrel,nrrel,irrel,nkmmax,nkmpmax)
-CALL bastrmat(nlmax-1,cgc,rc,crel,rrel,nkmmax,nkmpmax)
+
+ !for Jij-tensor calculation: allocate array to hold additional t-matrices
+! call init_t_dtmatJij_at(t_dtmatJij_at)
+!
+!
+!! lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll
+!! lllllllllll calculate the left-hand side solution lllllllllllllllllllllllllllllllllllll
+!! contruct the spin-orbit coupling hamiltonian and add to potential
+! call spinorbit_ham(lmax,lmmaxd,vins,rnew, &
+! eryd,zat,cvlight,socscale,nsra,nspin,lmpotd, &
+! theta,phi,ipan_intervall,rpan_intervall, &
+! npan_tot,ncheb,irmdnew,nrmaxd, &
+! vnspll0,vnspll1, &
+! 'transpose',soc)
+!
+!! extend matrix for the sra treatment
+! vnspll=czero
+! if (nsra.eq.2) then
+! if (use_sratrick.eq.0) then
+! call vllmatsra(vnspll1,vnspll,rnew, &
+! lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'ref=0')
+! elseif (use_sratrick.eq.1) then
+! call vllmatsra(vnspll1,vnspll,rnew, &
+! lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'ref=vsph')
+! endif
+! else
+! vnspll=vnspll1
+! endif
+!
+!! calculate the source terms in the lippmann-schwinger equation
+!! these are spherical hankel and bessel functions
+! hlk=czero
+! jlk=czero
+! hlk2=czero
+! jlk2=czero
+! gmatprefactor=czero
+! jlk_index = 0
+! call rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
+! lmmaxso,1,jlk_index,hlk, &
+! jlk,hlk2,jlk2, &
+! gmatprefactor)
+!
+!! using spherical potential as reference
+!! notice that exchange the order of left and right hankel/bessel functions
+! if (use_sratrick.eq.1) then
+! tmatsph=czero
+! call calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
+! lmpotd,lmmaxso,rnew,vins,ncheb,npan_tot,rpan_intervall, &
+! jlk_index,hlk2,jlk2,hlk, &
+! jlk,gmatprefactor,tmatsph, &
+! use_sratrick)
+! endif
+!
+!! calculate the tmat and wavefunctions
+! rllleft(:,:,:)=czero
+! sllleft(:,:,:)=czero
+!
+!! left solutions
+!! notice that exchange the order of left and right hankel/bessel functions
+! tmat0=czero
+! alpha0=czero ! lly
+! call rllsll(rpan_intervall,rnew,vnspll, &
+! rllleft,sllleft,tmat0,ncheb, &
+! npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1),irmdnew, &
+! nrmaxd,nsra,jlk_index,hlk2,jlk2, &
+! hlk,jlk,gmatprefactor, &
+! '1','1','0',use_sratrick)
+! if (nsra.eq.2) then
+! rllleft(lmmaxso+1:nvec*lmmaxso,:)= &
+! rllleft(lmmaxso+1:nvec*lmmaxso,:)/cvlight
+! sllleft(lmmaxso+1:nvec*lmmaxso,:,:)= &
+! sllleft(lmmaxso+1:nvec*lmmaxso,:,:)/cvlight
+! endif
+!! lllllllllll calculate the left-hand side solution lllllllllllllllllllllllllllllllllllll
+!! lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll
+!
+! call calc_dtmatjij(lmaxd,lmmaxd,lmmaxso,lmpotd,ntotd,nrmaxd, &
+! nsra,irmdnew,nspin,vins,rllleft,rll, &
+! rpan_intervall, &
+! ipan_intervall,npan_tot,ncheb,cleb,icleb,iend,ncleb,rnew, &
+! theta,phi,t_dtmatjij_at%dtmat_xyz(:,:,:,ie_num))
-RETURN
-END SUBROUTINE drvbastrans
-
-SUBROUTINE changerep(a,mode,b,n,m,rc,crel,rrel,text,ltext)
-! ********************************************************************
-! * *
-! * change the representation of matrix A and store in B *
-! * according to MODE: *
-! * *
-! * RLM>REL non-relat. REAL spher. harm. > (kappa,mue) *
-! * REL>RLM (kappa,mue) > non-relat. REAL spher. harm. *
-! * CLM>REL non-relat. CMPLX. spher. harm. > (kappa,mue) *
-! * REL>CLM (kappa,mue) > non-relat. CMPLX. spher. harm. *
-! * RLM>CLM non-relat. REAL spher. harm. > CMPLX. spher. harm. *
-! * CLM>RLM non-relat. CMPLX. spher. harm. > REAL spher. harm. *
-! * *
-! * the non-relat. representations include the spin index *
-! * *
-! * for LTEXT > 0 the new matrix B is printed *
-! * *
-! ********************************************************************
-IMPLICIT REAL*8(a-h,o-z)
+! end if!t_dtmatjij_at%calculate
+
+
+! add spherical contribution of tmatrix
+ IF (use_sratrick == 1) THEN
+ DO lm1=1,lmmaxso
+ tmatll(lm1,lm1)=tmatll(lm1,lm1)+tmatsph(jlk_index(lm1))
+ END DO
+ END IF
+ TmatN(:,:) = tmatll(:,:)
+deallocate(vins)
+deallocate(vnspll0)
+deallocate(vnspll1)
+deallocate(vnspll)
+deallocate(hlk)
+deallocate(jlk)
+deallocate(hlk2)
+deallocate(jlk2)
+deallocate(tmatsph)
+deallocate(alpha)
+deallocate(rll)
+deallocate(ull)
-COMPLEX*16, INTENT(IN OUT) :: a(m,m)
-CHARACTER (LEN=7), INTENT(IN) :: mode
-COMPLEX*16, INTENT(IN OUT) :: b(m,m)
-INTEGER, INTENT(IN OUT) :: n
-INTEGER, INTENT(IN OUT) :: m
-COMPLEX*16, INTENT(IN OUT) :: rc(m,m)
-COMPLEX*16, INTENT(IN OUT) :: crel(m,m)
-COMPLEX*16, INTENT(IN OUT) :: rrel(m,m)
-CHARACTER (LEN=*), INTENT(IN) :: text
-INTEGER, INTENT(IN) :: ltext
+END SUBROUTINE tmat_newsolver
+SUBROUTINE rhovalnew(ldorhoef,ielast,nsra,nspin,lmax,ez,wez,zat, &
+ socscale,cleb,icleb,iend,ifunm,lmsp,ncheb, &
+ npan_tot,npan_log,npan_eq,rmesh,irws, &
+ rpan_intervall,ipan_intervall, &
+ rnew,vinsnew,thetasnew,theta,phi,angle_fixed, &
+ moment_x,moment_y,moment_z, &
+ ipot, &
+ den_out,espv,rho2ns,r2nef,gmatn, muorb, &
+ lpotd,lmaxd,irmd,irmd_new,iemxd,soc,enable_quad_prec) ! new parameters
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-21 Time: 11:39:57
-!*** Start of declarations rewritten by SPAG
+IMPLICIT NONE
-! PARAMETER definitions
+LOGICAL, INTENT(IN) :: ldorhoef
+INTEGER, INTENT(IN) :: ielast
+INTEGER, INTENT(IN) :: nsra
+INTEGER, INTENT(IN) :: nspin
+INTEGER, INTENT(IN) :: lmax
+DOUBLE COMPLEX, INTENT(IN) :: ez(:)
+DOUBLE COMPLEX, INTENT(IN) :: wez(:)
+DOUBLE PRECISION, INTENT(IN) :: zat
+DOUBLE PRECISION, INTENT(IN) :: socscale
+DOUBLE PRECISION, INTENT(IN) :: cleb(:)
+INTEGER, INTENT(IN) :: icleb(:,:)
+INTEGER, INTENT(IN) :: iend
+INTEGER, INTENT(IN) :: ifunm(:)
+INTEGER, INTENT(IN) :: lmsp(:)
+INTEGER, INTENT(IN) :: ncheb
+INTEGER, INTENT(IN) :: npan_tot
+INTEGER, INTENT(IN) :: npan_log
+INTEGER, INTENT(IN) :: npan_eq
+DOUBLE PRECISION, INTENT(IN) :: rmesh(:)
+INTEGER, INTENT(IN) :: irws
+DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
+INTEGER, INTENT(IN) :: ipan_intervall(0:)
+DOUBLE PRECISION, INTENT(IN) :: rnew(:)
+DOUBLE PRECISION, INTENT(IN) :: vinsnew(:,:,:)
+DOUBLE PRECISION, INTENT(IN) :: thetasnew(:,:)
+DOUBLE PRECISION, INTENT(INOUT) :: theta
+DOUBLE PRECISION, INTENT(INOUT) :: phi
+INTEGER (kind=1), INTENT(IN) :: angle_fixed
+DOUBLE PRECISION, INTENT(OUT) :: moment_x
+DOUBLE PRECISION, INTENT(OUT) :: moment_y
+DOUBLE PRECISION, INTENT(OUT) :: moment_z
+INTEGER, INTENT(IN) :: ipot
+DOUBLE COMPLEX, INTENT(OUT) :: den_out(0:,:,:)
+DOUBLE PRECISION, INTENT(OUT) :: espv(0:,:)
+DOUBLE PRECISION, INTENT(OUT) :: rho2ns(:,:,:)
+DOUBLE PRECISION, INTENT(OUT) :: r2nef(:,:,:)
+DOUBLE COMPLEX, INTENT(IN) :: gmatn(:,:,:)
+DOUBLE PRECISION, INTENT(OUT) :: muorb(0:,:)
+INTEGER, INTENT(IN) :: lpotd
+INTEGER, INTENT(IN) :: lmaxd
+INTEGER, INTENT(IN) :: irmd
+INTEGER, INTENT(IN) :: irmd_new
+INTEGER, INTENT(IN) :: iemxd
+LOGICAL, INTENT(IN) :: soc
+LOGICAL, INTENT(IN) :: enable_quad_prec
-COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
-COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
+DOUBLE PRECISION, PARAMETER :: cvlight=274.0720442D0
+DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
+DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
-! Dummy arguments
+INTEGER :: lmmaxd, lmaxd1, lmmaxso, lmpotd, lmxspd, nrmaxd
+DOUBLE COMPLEX eryd, ek,df
+
+DOUBLE COMPLEX, allocatable :: tmatll(:,:), &
+ tmattemp(:,:),alpha(:,:),alphaleft(:,:)
+DOUBLE COMPLEX, allocatable :: gmatll(:,:,:), gmat0(:,:)
+INTEGER :: ir,use_sratrick,nvec,lm1,lm2,ie,irmdnew,imt1, &
+ jspin,idim,iorb
+DOUBLE PRECISION :: pi,thetanew,phinew
+DOUBLE COMPLEX gmatprefactor
+DOUBLE PRECISION, allocatable :: vins(:,:,:)
+DOUBLE COMPLEX,allocatable :: vnspll0(:,:,:),vnspll1(:,:,:), vnspll(:,:,:)
+DOUBLE COMPLEX, allocatable :: hlk(:,:),jlk(:,:), hlk2(:,:),jlk2(:,:)
+DOUBLE COMPLEX, allocatable :: rll(:,:,:),ull(:,:,:), &
+ rllleft(:,:,:),ullleft(:,:,:),sllleft(:,:,:)
+DOUBLE COMPLEX, allocatable :: tmatsph(:)
+DOUBLE COMPLEX, allocatable :: cden(:,:,:), &
+ cdenlm(:,:,:),cdenns(:,:),rho2nsc(:,:,:),r2nefc(:,:,:), &
+ rho2nsnew(:,:,:),r2nefnew(:,:,:),r2orbc(:,:,:), &
+ rho2nsc_loop(:,:,:,:), r2nefc_loop(:,:,:)
+DOUBLE COMPLEX, allocatable:: den(:,:,:,:),denlm(:,:,:,:)
+DOUBLE COMPLEX rho2(4),rho2int(4),temp1
+DOUBLE COMPLEX rho2ns_temp(2,2),dentemp
+DOUBLE PRECISION :: moment(3),totmoment,totxymoment
+DOUBLE PRECISION :: denorbmom(3),denorbmomsp(2,4), &
+ denorbmomlm(0:lmaxd,3),denorbmomns(3)
+DOUBLE COMPLEX, allocatable :: cdentemp(:), rhotemp(:,:),rhonewtemp(:,:)
+INTEGER, allocatable :: jlk_index(:)
+LOGICAL :: test,opt
+EXTERNAL test,opt
+INTEGER :: iq,nqdos ! qdos ruess: number of qdos points
+EXTERNAL zgemm,dscal,daxpy
+lmmaxd = (lmaxd+1)**2
+lmaxd1 = lmaxd+1
+lmmaxso = 2*lmmaxd
+lmpotd = (lpotd+1)**2
+lmxspd = (2*lpotd+1)**2
+nrmaxd=irmd_new
-! Local variables
+allocate(tmatll(lmmaxso,lmmaxso))
+allocate(tmattemp(lmmaxso,lmmaxso))
+allocate(alpha(lmmaxso,lmmaxso))
+allocate(alphaleft(lmmaxso,lmmaxso))
+allocate(gmatll(lmmaxso,lmmaxso,iemxd))
+allocate(gmat0(lmmaxso,lmmaxso))
+!allocate(dentmp(0:lmaxd1,2))
+allocate(jlk_index(2*lmmaxso))
-INTEGER :: key
-COMPLEX*16 w1(m,m)
+pi=4D0*DATAN(1D0)
+irmdnew= npan_tot*(ncheb+1)
+imt1=ipan_intervall(npan_log+npan_eq)+1
+allocate(vins(irmdnew,lmpotd,nspin))
+vins=0D0
+DO lm1=1,lmpotd
+ DO ir=1,irmdnew
+ vins(ir,lm1,1)=vinsnew(ir,lm1,ipot)
+ vins(ir,lm1,nspin)=vinsnew(ir,lm1,ipot+nspin-1)
+ END DO
+END DO
-!*** End of declarations rewritten by SPAG
+!c set up the non-spherical ll' matrix for potential VLL'
+IF (NSRA.EQ.2) THEN
+USE_SRATRICK=1
+ELSE
+USE_SRATRICK=0
+ENDIF
+allocate(vnspll0(lmmaxso,lmmaxso,irmdnew))
+allocate(vnspll1(lmmaxso,lmmaxso,irmdnew))
+vnspll0=czero
+CALL vllmat(1,irmdnew,lmmaxd,lmmaxso,vnspll0,vins, &
+ cleb,icleb,iend,nspin,zat,rnew,use_sratrick)
-!---------------------- transform MAT from (kappa,mue) to REAL (l,ml,ms)
-IF ( mode == 'REL>RLM' ) THEN
- CALL zgemm('N','N',n,n,n,c1,rrel,m,a,m,c0,w1,m)
- CALL zgemm('N','C',n,n,n,c1,w1,m,rrel,m,c0,b,m)
- key = 2
-ELSE IF ( mode == 'RLM>REL' ) THEN
- CALL zgemm('C','N',n,n,n,c1,rrel,m,a,m,c0,w1,m)
- CALL zgemm('N','N',n,n,n,c1,w1,m,rrel,m,c0,b,m)
- key = 3
-ELSE IF ( mode == 'REL>CLM' ) THEN
- CALL zgemm('N','N',n,n,n,c1,crel,m,a,m,c0,w1,m)
- CALL zgemm('N','C',n,n,n,c1,w1,m,crel,m,c0,b,m)
- key = 2
-ELSE IF ( mode == 'CLM>REL' ) THEN
- CALL zgemm('C','N',n,n,n,c1,crel,m,a,m,c0,w1,m)
- CALL zgemm('N','N',n,n,n,c1,w1,m,crel,m,c0,b,m)
- key = 3
-ELSE IF ( mode == 'CLM>RLM' ) THEN
- CALL zgemm('N','N',n,n,n,c1,rc,m,a,m,c0,w1,m)
- CALL zgemm('N','C',n,n,n,c1,w1,m,rc,m,c0,b,m)
- key = 2
-ELSE IF ( mode == 'RLM>CLM' ) THEN
- CALL zgemm('C','N',n,n,n,c1,rc,m,a,m,c0,w1,m)
- CALL zgemm('N','N',n,n,n,c1,w1,m,rc,m,c0,b,m)
- key = 2
+! initial allocate
+IF (nsra == 2) THEN
+ allocate(vnspll(2*lmmaxso,2*lmmaxso,irmdnew))
ELSE
- WRITE (*,*) ' MODE = ',mode
- STOP 'in <ROTATE> MODE not allowed'
+ allocate(vnspll(lmmaxso,lmmaxso,irmdnew))
END IF
-IF ( ltext > 0 ) CALL cmatstr(text,ltext,b,n,m,key,key,0,1D-8,6)
-! IF ( LTEXT.GT.0 ) CALL CMATSTR(TEXT,LTEXT,B,N,M,KEY,KEY,0,1D-12,6)
-END SUBROUTINE changerep
-
-SUBROUTINE create_newmesh_new(r_log,npan_log,npan_eq,ncheb, &
- npan_lognew,npan_eqnew, &
- npan_tot,rnew,rpan_intervall,ipan_intervall, &
- thetasnew,thetas,nfu,radial_mesh) ! new parameters
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-03-29 Time: 17:20:39
-
-!use DimParams_mod
-!use InputParams_mod
-use read_formatted_shapefun_mod, only: ShapefunFile
-
-!INTEGER, INTENT(IN) :: nspin
-DOUBLE PRECISION, INTENT(IN) :: r_log
-INTEGER, INTENT(IN) :: npan_log
-INTEGER, INTENT(IN) :: npan_eq
-INTEGER, INTENT(IN) :: ncheb
-INTEGER, INTENT(OUT) :: npan_lognew
-INTEGER, INTENT(OUT) :: npan_eqnew
-INTEGER, INTENT(OUT) :: npan_tot
-DOUBLE PRECISION, INTENT(OUT) :: rnew(:)
-!DOUBLE PRECISION, INTENT(IN) :: thetas(irid,nfund,ncelld)
-DOUBLE PRECISION, INTENT(OUT) :: rpan_intervall(0:)
-INTEGER, INTENT(OUT) :: ipan_intervall(0:)
-DOUBLE PRECISION, INTENT(OUT) :: thetasnew(:,:)
-DOUBLE PRECISION, INTENT(IN) :: thetas(:,:)
-INTEGER, INTENT(IN) :: nfu
-type(RadialMeshData), INTENT(IN) :: radial_mesh
-!type(ShapefunFile), intent(in) :: sfile
-!type(InputParams), intent(in) :: params
-!type(DimParams), intent(in) :: dims
-
-!IMPLICIT NONE
-!INCLUDE 'inc.p'
-
-
-!INTEGER, PARAMETER :: lmmaxd= (lmaxd+1)**2
-
-!INTEGER, PARAMETER :: lmpotd= (lpotd+1)**2
-
-!INTEGER, PARAMETER :: irmind= irmd-irnsd
-!INTEGER :: npan_inst
-!INTEGER :: npan_lognew(dims%naez)
-
-
+allocate(hlk(4*(lmax+1),irmdnew))
+allocate(jlk(4*(lmax+1),irmdnew))
+allocate(hlk2(4*(lmax+1),irmdnew))
+allocate(jlk2(4*(lmax+1),irmdnew))
+allocate(tmatsph(2*(lmax+1)))
+allocate(rll(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(rllleft(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(ull(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(ullleft(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(sllleft(nsra*lmmaxso,lmmaxso,irmdnew))
+allocate(cden(irmdnew,0:lmaxd,4))
+allocate(cdenlm(irmdnew,lmmaxd,4))
+allocate(cdenns(irmdnew,4))
+allocate(rho2nsc(irmdnew,lmpotd,4))
+allocate(rho2nsc_loop(irmdnew,lmpotd,4,ielast))
+allocate(rho2nsnew(irmd,lmpotd,4))
+allocate(r2nefc(irmdnew,lmpotd,4))
+allocate(r2nefc_loop(irmdnew,lmpotd,4))
+allocate(r2nefnew(irmd,lmpotd,4))
+allocate(r2orbc(irmdnew,lmpotd,4))
+allocate(cdentemp(irmdnew))
+allocate(den(0:lmaxd1,iemxd,2,1),denlm(lmmaxd,iemxd,2,1))
+rho2nsc=czero
+rho2nsc_loop=czero
+r2nefc=czero
+r2nefc_loop=czero
+r2orbc=czero
+rho2ns=0.d0 ! fivos 19.7.2014, this was CZERO
+r2nef=0.d0 ! fivos 19.7.2014, this was CZERO
+rho2nsnew=czero
+r2nefnew=czero
+den=czero
+espv=0D0
+rho2int=czero
+denorbmom=0D0
+denorbmomsp=0D0
+denorbmomlm=0D0
+denorbmomns=0D0
+thetanew=0D0
+phinew=0D0
-DOUBLE PRECISION, PARAMETER :: fac=2D0
-INTEGER :: ipotm,ir2,ip, &
- ishift,ilogpanshift,ilinpanshift,npan_logtemp,npan_inst,imin,imax,iminnew,imaxnew,lm1
-DOUBLE PRECISION :: rmin,rmax,rval
-!type(RadialMeshData) :: radial_mesh
+GMAT0 = czero
+gmatll = czero
-! set up radial mesh
-!call createRadialMeshData(radial_mesh, dims%irmd, sfile%mesh(i1)%npan+1)
+DO ir=1,3
+ DO lm1=0,lmaxd1+1
+ muorb(lm1,ir)=0D0
+ END DO
+END DO
-! local arrays to be filled with data from 'sfile'
-! ---------------------------------------------
-!DOUBLE PRECISION, allocatable :: r(:,:)
-!INTEGER, allocatable :: irmin(:)
-!INTEGER, allocatable :: irws(:)
-!INTEGER, allocatable :: ipan(:)
-!INTEGER, allocatable :: ircut(:,:)
-!DOUBLE PRECISION, allocatable :: thetasin(:,:,:)
+ nqdos = 1 ! qdos ruess
-!allocate(r(size(sfile%mesh(i1)%r),dims%naez))
-!allocate(irmin(dims%naez))
-!allocate(irws(dims%naez))
-!allocate(ipan(dims%naez))
-!allocate(ircut(size(sfile%mesh(i1)%ircut),dims%naez))
-!allocate(thetasin(dims%irid,sfile%shapes(1)%nfu,dims%naez)) ! #shapefunctions = #atoms in KKRnano, can nfu be different for different shapes?!
+DO ie=1,ielast
-!DO i1 = 1,dims%naez
-
- !call createRadialMeshData(meshdata, irmd, ipand)
- !call initRadialMesh(meshdata, alat, sfile%mesh(cell_index)%xrn, &
- ! sfile%mesh(cell_index)%drn, sfile%mesh(cell_index)%nm, irmd-irid, irns)
-! r(:,i1) = sfile%mesh(i1)%r
-! irmin(i1) = sfile%mesh(i1)%irmin
-! irws(i1) = sfile%mesh(i1)%irws
-! ipan(i1) = sfile%mesh(i1)%ipan
-! ircut(:,i1) = sfile%mesh(i1)%ircut
-! DO lm1=1,sfile%shapes(i1)%nfu
-! thetasin(:,lm1,i1)=sfile%shapes(i1)%thetas(:,lm1) ! #shapefunctions = #atoms in KKRnano
-! ENDDO
-!ENDDO
-! ----------------------------------------------
-
-
-thetasnew=0D0
-ipotm=0
-
-!DO i1 = 1,dims%naez ! JM: NATYPD instead of NAEZ
-
- ! set up radial mesh for atom i1
-! call createRadialMeshData(radial_mesh, dims%irmd, sfile%mesh(i1)%npan+1)
-! call initRadialMesh(radial_mesh, params%alat, sfile%mesh(i1)%xrn, &
-! sfile%mesh(i1)%drn, sfile%mesh(i1)%nm, &
-! dims%irmd-dims%irid, dims%irnsd)
-
-! ipot=dims%nspind*(i1-1)+1
- npan_inst = radial_mesh%ipan-1
- npan_tot = npan_log+npan_eq+npan_inst
+ eryd=ez(ie)
+ ek=SQRT(eryd)
+ df=wez(ie)/DBLE(nspin)
+ IF (nsra == 2) ek = SQRT( eryd + eryd*eryd/(cvlight*cvlight) ) * &
+ ( 1D0 + eryd/(cvlight*cvlight) )
+! recalculate wavefuntions, also include left solution
+! contruct the spin-orbit coupling hamiltonian and add to potential
+ CALL spinorbit_ham(lmax,lmmaxd,vins,rnew, &
+ eryd,zat,cvlight,socscale,nspin,lmpotd, &
+ theta,phi,ipan_intervall,rpan_intervall, npan_tot,ncheb,irmdnew,nrmaxd, &
+ vnspll0,vnspll1,'1',soc)
-! log panel
- rmin=radial_mesh%r(2)
- rmax=r_log
- rval=0D0
- ishift=0
- IF (r_log > radial_mesh%r(radial_mesh%irmin)) THEN
- ilogpanshift=1
- ilinpanshift=0
+!c extend matrix for the SRA treatment
+ vnspll=czero
+ IF (nsra == 2) THEN
+ IF (use_sratrick == 0) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
+ ELSE IF (use_sratrick == 1) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
+ END IF
ELSE
- ilogpanshift=0
- ilinpanshift=1
+ vnspll=vnspll1
END IF
- IF (ilinpanshift == 1) THEN
- STOP 'non-spherical part of the potential needs to be inside the log panel'
- END IF
-
- DO ip=0,npan_log-ilogpanshift
- rval=(fac**ip-1D0)/(fac**(npan_log-ilogpanshift)-1D0)
- rpan_intervall(ip+ishift)= rmin+rval*(rmax-rmin)
- ipan_intervall(ip+ishift)= (ip+ishift)*(ncheb+1)
- IF (ishift == 0.AND. rpan_intervall(ip) > radial_mesh%r(radial_mesh%irmin)) THEN
- ishift=1
- npan_logtemp=ip
- rpan_intervall(ip+1)=rpan_intervall(ip)
- ipan_intervall(ip+1)=(ip+ishift)*(ncheb+1)
- rpan_intervall(ip)=radial_mesh%r(radial_mesh%irmin)
- ipan_intervall(ip)=ip*(ncheb+1)
- END IF
- END DO ! NPAN_LOG
+!c calculate the source terms in the Lippmann-Schwinger equation
+!c these are spherical hankel and bessel functions
+ hlk=czero
+ jlk=czero
+ hlk2=czero
+ jlk2=czero
+ gmatprefactor=czero
+ jlk_index=0
+ CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
+ lmmaxso,1,jlk_index,hlk, &
+ jlk,hlk2,jlk2, gmatprefactor)
-! equivalent panel
- ishift=0
- rmin=r_log
- rmax=radial_mesh%r(radial_mesh%ircut(1))
- DO ip=0,npan_eq-ilinpanshift
- rpan_intervall(ip+ishift+npan_log)=rmin+ip*(rmax-rmin)/ &
- (npan_eq-ilinpanshift)
- ipan_intervall(ip+ishift+npan_log)=(npan_log+ip+ishift)* (ncheb+1)
- END DO ! NPAN_EQ
+! using spherical potential as reference
+ IF (use_sratrick == 1) THEN
+ CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
+ rnew,vins,ncheb,npan_tot,rpan_intervall, &
+ jlk_index,hlk,jlk,hlk2, &
+ jlk2,gmatprefactor,tmatsph,use_sratrick,enable_quad_prec)
+ END IF
+
+!c calculate the tmat and wavefunctions
+ rllleft=czero
+ sllleft=czero
+
+!c right solutions
+ tmatll=czero
+ CALL rll_global_solutions(rpan_intervall,rnew,vnspll, &
+ rll,ull,tmatll, &
+ ncheb,npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1), &
+ irmdnew,nsra,jlk_index,hlk,jlk, &
+ hlk2,jlk2, gmatprefactor,use_sratrick,alpha)
+ IF (nsra == 2) THEN
+ rll(lmmaxso+1:nvec*lmmaxso,:,:)= &
+ rll(lmmaxso+1:nvec*lmmaxso,:,:)/cvlight
+ ull(lmmaxso+1:nvec*lmmaxso,:,:)= &
+ ull(lmmaxso+1:nvec*lmmaxso,:,:)/cvlight
+ END IF
+
+! left solutions
+! contruct the TRANSPOSE spin-orbit coupling hamiltonian and add to potential
+ CALL spinorbit_ham(lmax,lmmaxd,vins,rnew,eryd,zat, &
+ cvlight,socscale,nspin,lmpotd,theta,phi, &
+ ipan_intervall,rpan_intervall,npan_tot,ncheb, &
+ irmdnew,nrmaxd,vnspll0,vnspll1, 'transpose',soc)
+
+!c extend matrix for the SRA treatment
+ vnspll=czero
+ IF (nsra == 2) THEN
+ IF (use_sratrick == 0) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
+ ELSE IF (use_sratrick == 1) THEN
+ CALL vllmatsra(vnspll1,vnspll,rnew, &
+ lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
+ END IF
+ ELSE
+ vnspll=vnspll1
+ END IF
-! intersection zone
- DO ip=1,npan_inst
- rpan_intervall(npan_log+npan_eq+ip)=radial_mesh%r(radial_mesh%ircut(ip+1))
- ipan_intervall(npan_log+npan_eq+ip)=(npan_log+npan_eq+ip)* (ncheb+1)
- END DO ! NPAN_INST
+!c calculate the source terms in the Lippmann-Schwinger equation
+!c these are spherical hankel and bessel functions
+ hlk=czero
+ jlk=czero
+ hlk2=czero
+ jlk2=czero
+ gmatprefactor=czero
+ jlk_index=0
+ CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
+ lmmaxso,1,jlk_index,hlk, &
+ jlk,hlk2,jlk2, gmatprefactor)
- npan_eqnew=npan_eq+npan_log-npan_logtemp
- npan_lognew=npan_logtemp
+!c using spherical potential as reference
+! notice that exchange the order of left and right hankel/bessel functions
+ IF (use_sratrick == 1) THEN
+ CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
+ rnew,vins,ncheb,npan_tot,rpan_intervall, &
+ jlk_index,hlk2,jlk2, &
+ hlk,jlk,gmatprefactor,tmatsph,use_sratrick,enable_quad_prec)
+ END IF
- CALL chebmesh(npan_tot,ncheb,rpan_intervall(0:), rnew(1:))
+!c calculate the tmat and wavefunctions
+ rllleft=czero
+ sllleft=czero
-! interpolate shape function THETAS to new shape function THETASNEW
-! save THETAS to THETASIN
-! icell = i1 ! #shapefunctions = #atoms in KKRnano, JM: ICELL = NTCELL(I1)
- DO lm1=1,nfu
-! thetasin(:,lm1,icell)=sfile%shapes(icell)%thetas(:,lm1) ! get thetas for specific atom and lm1
- ir2=0
- DO ip=npan_lognew+npan_eqnew+1,npan_tot
- ir2=ir2+1
- imin=radial_mesh%ircut(ir2)+1
- imax=radial_mesh%ircut(ir2+1)
- iminnew=ipan_intervall(ip-1)+1
- imaxnew=ipan_intervall(ip)
- CALL interpolspline(radial_mesh%r(imin:imax),rnew(iminnew:imaxnew), &
- thetas(imin-radial_mesh%ircut(1):imax-radial_mesh%ircut(1),lm1), &
- thetasnew(iminnew:imaxnew,lm1), imax-imin+1,imaxnew-iminnew+1)
+!c left solutions
+! notice that exchange the order of left and right hankel/bessel functions
+ tmattemp=czero
+ CALL sll_global_solutions(rpan_intervall,rnew,vnspll, &
+ sllleft, &
+ ncheb,npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1), &
+ irmdnew,nsra,jlk_index,hlk2,jlk2, &
+ hlk,jlk, gmatprefactor,use_sratrick,enable_quad_prec,.true.)
+ CALL rll_global_solutions(rpan_intervall,rnew,vnspll, &
+ rllleft,ullleft,tmattemp, &
+ ncheb,npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1), &
+ irmdnew,nsra,jlk_index,hlk2,jlk2, &
+ hlk,jlk, gmatprefactor,use_sratrick,alphaleft)
+ IF (nsra == 2) THEN
+ rllleft(lmmaxso+1:nvec*lmmaxso,:,:)= &
+ rllleft(lmmaxso+1:nvec*lmmaxso,:,:)/cvlight
+ sllleft(lmmaxso+1:nvec*lmmaxso,:,:)= &
+ sllleft(lmmaxso+1:nvec*lmmaxso,:,:)/cvlight
+ END IF
+ DO iq = 1,nqdos ! qdos
+ den(:,ie,:,iq)=czero
+
+ GMAT0 = gmatn(:,:,ie)
+! rotate gmat from global frame to local frame
+ CALL rotatematrix(gmat0,theta,phi,lmmaxd,1)
+
+ DO lm1=1,lmmaxso
+ DO lm2=1,lmmaxso
+ gmatll(lm1,lm2,ie)=gmat0(lm1,lm2)
+ END DO
END DO
- END DO
-
-!call destroyRadialMeshData(radial_mesh)
-!END DO ! I1
-END SUBROUTINE create_newmesh_new
-
-
-SUBROUTINE chebmesh(npan,ncheb,ri,ro)
+! calculate density
+ CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
+ df,cleb,icleb,iend, &
+ irmdnew,thetasnew,ifunm,imt1,lmsp, &
+ rll, ull, rllleft,sllleft, &
+ cden,cdenlm, &
+ cdenns,rho2nsc_loop(:,:,:,ie),0, &
+ lmaxd)
+
+ DO jspin=1,4
+
+ DO lm1 = 0,lmax
+ cdentemp=czero
+ dentemp=czero
+ DO ir=1,irmdnew
+ cdentemp(ir)=cden(ir,lm1,jspin)
+ END DO
+ CALL intcheb_cell(cdentemp,dentemp, &
+ rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
+ rho2(jspin)=dentemp
+ rho2int(jspin)=rho2int(jspin)+rho2(jspin)*df
+ IF (jspin <= 2) THEN
+ den(lm1,ie,jspin,iq)=rho2(jspin)
+ END IF
+ END DO
+
+ IF (jspin <= 2) THEN
+ DO lm1 = 1,lmmaxd
+ cdentemp=czero
+ dentemp=czero
+ DO ir=1,irmdnew
+ cdentemp(ir)=cdenlm(ir,lm1,jspin)
+ END DO
+ CALL intcheb_cell(cdentemp,dentemp, &
+ rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
+ denlm(lm1,ie,jspin,iq)=dentemp
+ END DO
+ cdentemp=czero
+ dentemp=czero
+ DO ir=1,irmdnew
+ cdentemp(ir)=cdenns(ir,jspin)
+ END DO
+ CALL intcheb_cell(cdentemp,dentemp, &
+ rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
+ den(lmaxd1,ie,jspin,iq)=dentemp
+ rho2int(jspin)=rho2int(jspin)+den(lmaxd1,ie,jspin,iq)*df
+ END IF
+ END DO ! JSPIN
+
+ DO jspin=1,4
+ IF (jspin <= 2) THEN
+ DO lm1=0,lmaxd1
+ espv(lm1,jspin)=espv(lm1,jspin)+ &
+ DIMAG( eryd * den(lm1,ie,jspin,iq) * df )
+ END DO
+ END IF
+ END DO
+ END DO ! IQ = 1,NQDOS
+!END DO
-INTEGER, INTENT(IN) :: npan
-INTEGER, INTENT(IN) :: ncheb
-DOUBLE PRECISION, INTENT(IN) :: ri(0:npan)
-DOUBLE PRECISION, INTENT(OUT) :: ro(npan*(ncheb+1))
-!IMPLICIT NONE
+! get charge at the Fermi energy (IELAST)
+IF (ie == ielast.AND.ldorhoef) THEN
+ CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
+ cone,cleb,icleb,iend, &
+ irmdnew,thetasnew,ifunm,imt1,lmsp, &
+ rll, ull, rllleft,sllleft, &
+ cden,cdenlm, &
+ cdenns,r2nefc_loop,0, &
+ lmaxd)
+END IF
-INTEGER :: i,k,ik
-DOUBLE PRECISION :: tau,pi
+! get orbital moment
+DO iorb=1,3
+ CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
+ cone,cleb,icleb,iend, &
+ irmdnew,thetasnew,ifunm,imt1,lmsp, &
+ rll, ull, rllleft,sllleft, &
+ cden,cdenlm, &
+ cdenns,r2orbc,iorb, &
+ lmaxd)
+ DO jspin=1,4
+ IF (jspin <= 2) THEN
+ DO lm1=0,lmax
+ cdentemp=czero
+ dentemp=czero
+ DO ir=1,irmdnew
+ cdentemp(ir)=cden(ir,lm1,jspin)
+ END DO
+ CALL intcheb_cell(cdentemp,dentemp,rpan_intervall, &
+ ipan_intervall,npan_tot,ncheb,irmdnew)
+ rho2(jspin)=dentemp
+ muorb(lm1,jspin)=muorb(lm1,jspin)-DIMAG(rho2(jspin)*df)
+ denorbmom(iorb)=denorbmom(iorb)-DIMAG(rho2(jspin)*df)
+ denorbmomsp(jspin,iorb)=denorbmomsp(jspin,iorb)- DIMAG(rho2(jspin)*df)
+ denorbmomlm(lm1,iorb)=denorbmomlm(lm1,iorb)- DIMAG(rho2(jspin)*df)
+ cdentemp=czero
+ DO ir=1,irmdnew
+ cdentemp(ir)=cdenns(ir,jspin)
+ END DO
+ CALL intcheb_cell(cdentemp,temp1, &
+ rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
+ denorbmomns(iorb)=denorbmomns(iorb)-DIMAG(temp1*df)
+ END DO
+ END IF
+ END DO
+END DO ! IORB
+END DO ! IE loop
-pi=4D0*DATAN(1D0)
-DO i=1,npan
- DO k=0,ncheb
- ik=i*ncheb+i-k
- tau=DCOS(((2*k+1)*pi)/(2*(ncheb+1)))
- tau=0.5D0*((ri(i)-ri(i-1))*tau+ri(i)+ri(i-1))
- ro(ik)=tau
+DO ir=1,irmdnew
+ DO lm1=1,lmpotd
+ DO jspin=1,4
+ DO ie=1,ielast
+ rho2nsc(ir,lm1,jspin) = rho2nsc(ir,lm1,jspin) + &
+ rho2nsc_loop(ir,lm1,jspin,ie)
+ END DO
+ END DO
END DO
END DO
-END SUBROUTINE chebmesh
+ r2nefc(:,:,:) = r2nefc(:,:,:) + r2nefc_loop(:,:,:)
+allocate(rhotemp(irmdnew,lmpotd))
+allocate(rhonewtemp(irws,lmpotd))
+DO jspin=1,4
+ rhotemp=czero
+ rhonewtemp=czero
+ DO lm1=1,lmpotd
+ DO ir=1,irmdnew
+ rhotemp(ir,lm1)=rho2nsc(ir,lm1,jspin)
+ END DO
+ END DO
+ CALL cheb2oldgrid(irws,irmdnew,lmpotd,rmesh,ncheb,npan_tot, &
+ rpan_intervall,ipan_intervall, rhotemp,rhonewtemp,irmd)
+ DO lm1=1,lmpotd
+ DO ir=1,irws
+ rho2nsnew(ir,lm1,jspin)=rhonewtemp(ir,lm1)
+ END DO
+ END DO
+
+ rhotemp=czero
+ rhonewtemp=czero
+ DO lm1=1,lmpotd
+ DO ir=1,irmdnew
+ rhotemp(ir,lm1)=r2nefc(ir,lm1,jspin)
+ END DO
+ END DO
+ CALL cheb2oldgrid(irws,irmdnew,lmpotd,rmesh,ncheb,npan_tot, &
+ rpan_intervall,ipan_intervall, rhotemp,rhonewtemp,irmd)
+ DO lm1=1,lmpotd
+ DO ir=1,irws
+ r2nefnew(ir,lm1,jspin)=rhonewtemp(ir,lm1)
+ END DO
+ END DO
+END DO
+deallocate(rhotemp)
+deallocate(rhonewtemp)
+! calculate new THETA and PHI for non-colinear
+!IF (.NOT.test('FIXMOM ')) THEN
+if (angle_fixed == 0) then ! angle not fixed
+ rho2ns_temp(1,1)=rho2int(1)
+ rho2ns_temp(2,2)=rho2int(2)
+ rho2ns_temp(1,2)=rho2int(3)
+ rho2ns_temp(2,1)=rho2int(4)
+
+ CALL rotatematrix(rho2ns_temp,theta,phi,1,0)
+
+ rho2int(1)=rho2ns_temp(1,1)
+ rho2int(2)=rho2ns_temp(2,2)
+ rho2int(3)=rho2ns_temp(1,2)
+ rho2int(4)=rho2ns_temp(2,1)
+
+
+ moment(1)=DIMAG(rho2int(3)+rho2int(4))
+ moment(2)=-REAL(rho2int(3)-rho2int(4))
+ moment(3)=DIMAG(-rho2int(1)+rho2int(2))
-SUBROUTINE bastrmat(lmax,cgc,rc,crel,rrel,nkmmax,nkmpmax)
-! ********************************************************************
-! * *
-! * INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM *
-! * RELATIVISTIC TO REAL SPERICAL HARM. REPRESENTATION *
-! * *
-! * this is a special version of <STRSMAT> passing the *
-! * full BASis TRansformation MATrices RC, CREL and RREL *
-! * *
-! * 13/01/98 HE *
-! ********************************************************************
+ moment_x=moment(1)
+ moment_y=moment(2)
+ moment_z=moment(3)
+
+ totmoment=SQRT(moment(1)**2+moment(2)**2+moment(3)**2)
+ totxymoment=SQRT(moment(1)**2+moment(2)**2)
+
+ IF (ABS(totxymoment) > 1D-05) THEN
+ IF (ABS(moment(3)) < 1D-05) THEN
+ thetanew=pi/2D0
+ ELSE
+ thetanew=ACOS(moment(3)/totmoment)
+ END IF
+ IF (totxymoment < 1D-05) THEN
+ phinew=0D0
+ ELSE
+ phinew=DATAN2(moment(2),moment(1))
+ END IF
+ END IF
-IMPLICIT REAL*8(a-h,o-z)
+ ! UPDATE ANGLES
+! phi = phinew
+! theta = thetanew
-INTEGER, INTENT(IN) :: lmax
-REAL*8, INTENT(IN) :: cgc(nkmpmax,2)
-COMPLEX*16, INTENT(OUT) :: rc(nkmmax,nkmmax)
-COMPLEX*16, INTENT(OUT) :: crel(nkmmax,nkmmax)
-COMPLEX*16, INTENT(IN OUT) :: rrel(nkmmax,nkmmax)
-INTEGER, INTENT(IN) :: nkmmax
-INTEGER, INTENT(IN) :: nkmpmax
+ ! THETANEW=ACOS(MOMENT(3)/TOTMOMENT)
+! PHINEW=DATAN2(MOMENT(2),MOMENT(1))
+! WRITE(6,*) 'moment',moment(1),moment(2),moment(3)
+! WRITE(6,*) 'total moment',TOTMOMENT,TOTXYMOMENT
+! WRITE(6,*) 'angles', thetanew,phinew
+! WRITE(11,*) thetanew,phinew
+! WRITE(12,*) thetanew,phinew
-!*** Start of declarations rewritten by SPAG
+! Use old angles for rotation
+!if (angle_fixed == 1) then
+! thetanew = theta
+! phinew = phi
+!endif
-! PARAMETER definitions
+ CALL rotatevector(rho2nsnew,rho2ns,irws,lmpotd,thetanew,phinew, &
+ theta,phi,irmd)
+ CALL rotatevector(r2nefnew,r2nef,irws,lmpotd,thetanew,phinew, &
+ theta,phi,irmd)
-COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
-COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
-COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
+else ! angle fixed
-! Local variables
+ rho2ns_temp(1,1)=rho2int(1)
+ rho2ns_temp(2,2)=rho2int(2)
+ rho2ns_temp(1,2)=rho2int(3)
+ rho2ns_temp(2,1)=rho2int(4)
+
+ CALL rotatematrix(rho2ns_temp,theta,phi,1,0)
+
+ rho2int(1)=rho2ns_temp(1,1)
+ rho2int(2)=rho2ns_temp(2,2)
+ rho2int(3)=rho2ns_temp(1,2)
+ rho2int(4)=rho2ns_temp(2,1)
-INTEGER :: i,ikm,j,jp05,k,l,lm,lnr,m,muem05,muep05,nk,nkm,nlm
-REAL*8 w
+ moment(1)=DIMAG(rho2int(3)+rho2int(4))
+ moment(2)=-REAL(rho2int(3)-rho2int(4))
+ moment(3)=DIMAG(-rho2int(1)+rho2int(2))
-!*** End of declarations rewritten by SPAG
+ moment_x=moment(1)
+ moment_y=moment(2)
+ moment_z=moment(3)
+
+ rho2ns(:,:,:)=DIMAG(rho2nsnew(:,:,:))
+ r2nef(:,:,:)=DIMAG(r2nefnew(:,:,:))
+endif
-nk = 2*(lmax+1) + 1
-nlm = (lmax+1)**2
-nkm = 2*nlm
-! ===================================================
-! INDEXING:
-! IKM = L*2*(J+1/2) + J + MUE + 1
-! LM = L*(L+1) + M + 1
-! ===================================================
+idim = irmd*lmpotd
+CALL dscal(idim,2.d0,rho2ns(1,1,1),1)
+CALL daxpy(idim,-0.5D0,rho2ns(1,1,1),1,rho2ns(1,1,2),1)
+CALL daxpy(idim,1.0D0,rho2ns(1,1,2),1,rho2ns(1,1,1),1)
-! ----------------------------------------------------------------------
-! CREL transforms from COMPLEX (L,M,S) to (KAP,MUE) - representation
-! |LAM> = sum[LC] |LC> * CREL(LC,LAM)
-! ----------------------------------------------------------------------
-CALL cinit(nkmmax*nkmmax,crel)
+! --> do the same at the Fermi energy
-lm = 0
-DO lnr = 0,lmax
- DO m = -lnr,lnr
- lm = lm + 1
-
- ikm = 0
- DO k = 1,nk
- l = k/2
- IF ( 2*l == k ) THEN
- jp05 = l
- ELSE
- jp05 = l + 1
- END IF
-
- DO muem05 = -jp05,(jp05-1)
- muep05 = muem05 + 1
- ikm = ikm + 1
-
- IF ( l == lnr ) THEN
- IF ( muep05 == m ) crel(lm,ikm) = cgc(ikm,1)
- IF ( muem05 == m ) crel(lm+nlm,ikm) = cgc(ikm,2)
- END IF
-
- END DO
+CALL dscal(idim,2.d0,r2nef(1,1,1),1)
+CALL daxpy(idim,-0.5D0,r2nef(1,1,1),1,r2nef(1,1,2),1)
+CALL daxpy(idim,1.0D0,r2nef(1,1,2),1,r2nef(1,1,1),1)
+
+DO lm1=0,lmaxd1
+ DO ie=1,iemxd
+ DO jspin=1,nspin
+ den_out(lm1,ie,jspin) = den(lm1,ie,jspin,1)
END DO
-
END DO
END DO
-! ----------------------------------------------------------------------
-! RC transforms from REAL to COMPLEX (L,M,S) - representation
-! |LC> = sum[LR] |LR> * RC(LR,LC)
-! ----------------------------------------------------------------------
-CALL cinit(nkmmax*nkmmax,rc)
-
-w = 1.0D0/SQRT(2.0D0)
+! UPDATE ANGLES
+if (angle_fixed == 0) then
+phi = phinew
+theta = thetanew
+endif
-DO l = 0,lmax
- DO m = -l,l
- i = l*(l+1) + m + 1
- j = l*(l+1) - m + 1
-
- IF ( m < 0 ) THEN
- rc(i,i) = -ci*w
- rc(j,i) = w
- rc(i+nlm,i+nlm) = -ci*w
- rc(j+nlm,i+nlm) = w
- END IF
- IF ( m == 0 ) THEN
- rc(i,i) = c1
- rc(i+nlm,i+nlm) = c1
- END IF
- IF ( m > 0 ) THEN
- rc(i,i) = w*(-1.0D0)**m
- rc(j,i) = ci*w*(-1.0D0)**m
- rc(i+nlm,i+nlm) = w*(-1.0D0)**m
- rc(j+nlm,i+nlm) = ci*w*(-1.0D0)**m
- END IF
- END DO
-END DO
+deallocate(vins)
+deallocate(vnspll0)
+deallocate(vnspll1)
+deallocate(vnspll)
+deallocate(hlk)
+deallocate(jlk)
+deallocate(hlk2)
+deallocate(jlk2)
+deallocate(tmatsph)
+deallocate(tmattemp)
+deallocate(alpha)
+deallocate(alphaleft)
+deallocate(rll)
+deallocate(rllleft)
+deallocate(sllleft)
+deallocate(cden)
+deallocate(cdenlm)
+deallocate(cdenns)
+deallocate(rho2nsc,rho2nsc_loop)
+deallocate(rho2nsnew)
+deallocate(r2nefc,r2nefc_loop)
+deallocate(r2nefnew)
+deallocate(r2orbc)
+deallocate(cdentemp)
+deallocate(den,denlm)
+END SUBROUTINE rhovalnew
+SUBROUTINE rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll,ek, &
+ df,cleb,icleb,iend, &
+ irmdnew,thetasnew,ifunm,imt1, &
+ lmsp,rll,ull,rllleft,sllleft, &
+ cden,cdenlm,cdenns,rho2nsc,corbital, &
+ lmaxd)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-21 Time: 16:24:21
-! ----------------------------------------------------------------------
-! RREL transforms from REAL (L,M,S) to (KAP,MUE) - representation
-! |LAM> = sum[LR] |LR> * RREL(LR,LAM)
-! ----------------------------------------------------------------------
+IMPLICIT NONE
-CALL zgemm('N','N',nkm,nkm,nkm,c1,rc,nkmmax,crel,nkmmax,c0,rrel, nkmmax)
+INTEGER, INTENT(IN) :: nsra
+INTEGER, INTENT(IN) :: lmmaxd
+INTEGER, INTENT(IN) :: lmmaxso
+INTEGER, INTENT(IN) :: lmax
+DOUBLE COMPLEX, INTENT(IN) :: gmatll(:,:)
+DOUBLE COMPLEX, INTENT(IN) :: ek
+DOUBLE COMPLEX, INTENT(IN) :: df
+DOUBLE PRECISION, INTENT(IN) :: cleb(:)
+INTEGER, INTENT(IN) :: icleb(:,:)
+INTEGER, INTENT(IN) :: iend
+INTEGER, INTENT(IN) :: irmdnew
+DOUBLE PRECISION, INTENT(IN) :: thetasnew(:,:)
+INTEGER, INTENT(IN) :: ifunm(:)
+INTEGER, INTENT(IN) :: imt1
+INTEGER, INTENT(IN) :: lmsp(:)
+DOUBLE COMPLEX, INTENT(IN) :: rll(:,:,:)
+DOUBLE COMPLEX, INTENT(IN) :: ull(:,:,:)
+DOUBLE COMPLEX, INTENT(IN) :: rllleft(:,:,:)
+DOUBLE COMPLEX, INTENT(IN) :: sllleft(:,:,:)
+DOUBLE COMPLEX, INTENT(OUT) :: cden(:,0:,:)
+DOUBLE COMPLEX, INTENT(OUT) :: cdenlm(:,:,:)
+DOUBLE COMPLEX, INTENT(OUT) :: cdenns(:,:)
+DOUBLE COMPLEX, INTENT(OUT) :: rho2nsc(:,:,:)
+INTEGER, INTENT(IN) :: corbital
+INTEGER, INTENT(IN) :: lmaxd
-END SUBROUTINE bastrmat
+DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
+DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
+DOUBLE COMPLEX cltdf
-SUBROUTINE calccgc(ltab,kaptab,nmuetab,cgc,nkmax,nmuemax,nkmpmax)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:05:10
-
-! ********************************************************************
-! * *
-! * CLEBSCH-GORDON-COEFFICIENTS CGC(IKM,IS) *
-! * *
-! * IKM NUMBERS CGC FOR INCREASING K AND MUE *
-! * IKM = L*2*(J+1/2) + J + MUE + 1 *
-! * IS= 1/2 SPIN DOWN/UP *
-! * *
-! ********************************************************************
+INTEGER :: ir,jspin,lm1,lm2,lm3,m1,l1,j,ifun
+DOUBLE PRECISION :: c0ll
-IMPLICIT NONE
+DOUBLE COMPLEX, allocatable :: wr(:,:,:),qnsi(:,:),pnsi(:,:)
+INTEGER :: lmshift1(4),lmshift2(4)
+DOUBLE COMPLEX, allocatable :: loperator(:,:,:)
+EXTERNAL zgemm
+allocate(wr(lmmaxso,lmmaxso,irmdnew))
+allocate(qnsi(lmmaxso,lmmaxso))
+allocate(pnsi(lmmaxso,lmmaxso))
+allocate(loperator(lmmaxso,lmmaxso,3))
-INTEGER, INTENT(IN) :: ltab(nmuemax)
-INTEGER, INTENT(IN) :: kaptab(nmuemax)
-INTEGER, INTENT(IN) :: nmuetab(nmuemax)
-REAL*8, INTENT(OUT) :: cgc(nkmpmax,2)
-INTEGER, INTENT(IN) :: nkmax
-INTEGER, INTENT(IN) :: nmuemax
-INTEGER, INTENT(IN) :: nkmpmax
+wr=czero
+qnsi=czero
+pnsi=czero
+! set LMSHIFT value which is need to construct CDEN
+lmshift1(1)=0
+lmshift1(2)=lmmaxd
+lmshift1(3)=0
+lmshift1(4)=lmmaxd
+lmshift2(1)=0
+lmshift2(2)=lmmaxd
+lmshift2(3)=lmmaxd
+lmshift2(4)=0
+! for orbital moment
+IF (corbital /= 0) THEN
+ CALL calc_orbitalmoment(lmaxd,lmmaxso,loperator)
+END IF
-! Local variables
+c0ll=1D0/SQRT(16D0*ATAN(1D0))
+cden=czero
+cdenlm=czero
-INTEGER :: ikm,k,kappa,m
-REAL*8 j,l,mue,twolp1
+DO ir = 1,irmdnew
-ikm = 0
-DO k = 1,(nkmax+1)
- l = ltab(k)
- kappa = kaptab(k)
- j = ABS(kappa) - 0.5D0
- mue = -j - 1.0D0
- twolp1 = 2.0D0*l + 1.0D0
-
- IF ( kappa < 0 ) THEN
-
-! J = L + 1/2
- DO m = 1,nmuetab(k)
-
- mue = mue + 1.0D0
- ikm = ikm + 1
- cgc(ikm,1) = DSQRT((l-mue+0.5D0)/twolp1)
- cgc(ikm,2) = DSQRT((l+mue+0.5D0)/twolp1)
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ qnsi(lm1,lm2)=sllleft(lm1,lm2,ir)
+ pnsi(lm1,lm2)=ull(lm1,lm2,ir)
END DO
- ELSE
-! J = L - 1/2
- DO m = 1,nmuetab(k)
-
- mue = mue + 1.0D0
- ikm = ikm + 1
- cgc(ikm,1) = DSQRT((l+mue+0.5D0)/twolp1)
- cgc(ikm,2) = -DSQRT((l-mue+0.5D0)/twolp1)
-
+ END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,ek,pnsi, &
+ lmmaxso,qnsi,lmmaxso,czero,wr(1,1,ir),lmmaxso)
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ pnsi(lm1,lm2)=rllleft(lm1,lm2,ir)
+ END DO
+ END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
+ lmmaxso,gmatll,lmmaxso,czero,qnsi,lmmaxso)
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ pnsi(lm1,lm2)=rll(lm1,lm2,ir)
+ END DO
+ END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
+ lmmaxso,qnsi,lmmaxso,cone,wr(1,1,ir),lmmaxso)
+
+ IF (nsra == 2) THEN
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ qnsi(lm1,lm2)=-sllleft(lm1+lmmaxso,lm2,ir)
+ pnsi(lm1,lm2)=ull(lm1+lmmaxso,lm2,ir)
+ END DO
+ END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,ek,pnsi, &
+ lmmaxso,qnsi,lmmaxso,cone,wr(1,1,ir),lmmaxso)
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ pnsi(lm1,lm2)=-rllleft(lm1+lmmaxso,lm2,ir)
+ END DO
+ END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
+ lmmaxso,gmatll,lmmaxso,czero,qnsi,lmmaxso)
+ DO lm1 = 1,lmmaxso
+ DO lm2 = 1,lmmaxso
+ pnsi(lm1,lm2)=rll(lm1+lmmaxso,lm2,ir)
+ END DO
END DO
+ CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
+ lmmaxso,qnsi,lmmaxso,cone,wr(1,1,ir),lmmaxso)
END IF
+! for orbital moment
+ IF (corbital /= 0) THEN
+ CALL zgemm('N','N',lmmaxso,lmmaxso,lmmaxso,cone, &
+ loperator(1,1,corbital),lmmaxso,wr(1,1,ir), lmmaxso,czero,pnsi,lmmaxso)
+ DO lm1=1,lmmaxso
+ DO lm2=1,lmmaxso
+ wr(lm1,lm2,ir)=pnsi(lm1,lm2)
+ END DO
+ END DO
+ END IF
-END DO
-
-END SUBROUTINE calccgc
-
-!*==cmatstr.f processed by SPAG 6.05Rc at 15:50 on 12 Oct 2002
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:05:17
-
-SUBROUTINE cmatstr(str,lstr,a,n,m,mlin,mcol,ijq,tolp,k_fmt_fil)
-! ********************************************************************
-! * *
-! * writes structure of COMPLEX NxN matrix A *
-! * *
-! * M is the actual array - size used for A *
-! * MLIN/COL MODE for line and column indexing *
-! * 0: plain, 1: (l,ml), 2: (l,ml,ms), 3: (kap,mue) *
-! * TOL tolerance for difference *
-! * IJQ if IJQ > 1000 pick IQ-JQ-block matrix *
-! * assuming IJQ = IQ*1000 + JQ *
-! * else: no IQ-JQ-indexing *
-! * K_FMT_FIL output channel *
-! * a negative sign suppresses table at the end *
-! * *
-! * any changes should be done in RMATSTR as well !!!!!!!!!!!!!!! *
-! * *
-! ********************************************************************
-
-IMPLICIT COMPLEX*16(a-h,o-z)
-
-CHARACTER (LEN=*), INTENT(IN) :: str
-INTEGER, INTENT(IN) :: lstr
-COMPLEX*16, INTENT(IN OUT) :: a(m,m)
-INTEGER, INTENT(IN) :: n
-INTEGER, INTENT(IN) :: m
-INTEGER, INTENT(IN) :: mlin
-INTEGER, INTENT(IN) :: mcol
-INTEGER, INTENT(IN) :: ijq
-REAL*8, INTENT(IN) :: tolp
-INTEGER, INTENT(IN) :: k_fmt_fil
-
-!*** Start of declarations rewritten by SPAG
-
-! PARAMETER definitions
+ DO jspin = 1,4
+ DO lm1 = 1,lmmaxd
+ DO lm2 = 1,lm1-1
+ wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)= &
+ wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)+ &
+ wr(lm2+lmshift1(jspin),lm1+lmshift2(jspin),ir)
+ END DO
+ END DO
+ END DO ! JSPIN
+
+END DO !IR
-COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
+! first calculate the spherical symmetric contribution
-! Local variables
+DO l1 = 0,lmax
+
+ DO m1 = -l1,l1
+ lm1 = l1*(l1+1)+m1+1
+ DO ir = 1,irmdnew
+ DO jspin=1,4
+ cden(ir,l1,jspin) = cden(ir,l1,jspin)+ &
+ wr(lm1+lmshift1(jspin),lm1+lmshift2(jspin),ir)
+ cdenlm(ir,lm1,jspin) = wr(lm1+lmshift1(jspin),lm1+lmshift2(jspin),ir)
+ END DO ! JPSIN
+ END DO ! IR
+ END DO ! M1
+
+ DO jspin = 1,4
+ DO ir = 1,irmdnew
+ rho2nsc(ir,1,jspin) = rho2nsc(ir,1,jspin)+ c0ll*(cden(ir,l1,jspin)*df)
+ END DO ! IR
+
+ DO ir=imt1+1,irmdnew
+ cden(ir,l1,jspin) = cden(ir,l1,jspin)*thetasnew(ir,1)*c0ll
+
+ DO m1 = -l1,l1
+ lm1 = l1*(l1+1)+m1+1
+ cdenlm(ir,lm1,jspin) = cdenlm(ir,lm1,jspin) *thetasnew(ir,1)*c0ll
+ END DO ! M1
+ END DO ! IR
+
+ END DO ! JSPIN
+
+END DO ! L1
-COMPLEX*16 b(n,n),ca,cb,arg,dtab(0:n*n)
-CHARACTER (LEN=1) :: CHAR
-LOGICAL :: same,small
-CHARACTER (LEN=1) :: ctab(0:n*n),vz(-1:+1)
-DOUBLE PRECISION :: DBLE
-CHARACTER (LEN=150) :: fmt1,fmt2,fmt3,fmt4
-INTEGER :: i,i1,ic0,id,il,ilsep(20),ipt(218),iq,isl,iw(m),j, &
- j0,jp,jq,k,l3,lf,mm,n1,n2,n3,nc,nd,nfil,nk,nm,nm1,nm2,nm3, nnon0,nsl
-INTEGER :: ICHAR,ISIGN,nint
-REAL*8 tol
+cdenns=czero
-!*** End of declarations rewritten by SPAG
+DO j = 1,iend
+ lm1 = icleb(j,1)
+ lm2 = icleb(j,2)
+ lm3 = icleb(j,3)
+ cltdf = df*cleb(j)
+
+ DO jspin = 1,4
+ DO ir = 1,irmdnew
+ rho2nsc(ir,lm3,jspin) = rho2nsc(ir,lm3,jspin) + &
+ (cltdf*wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir))
+ END DO
+
+ IF (lmsp(lm3) > 0) THEN
+ ifun = ifunm(lm3)
+ DO ir=imt1+1,irmdnew
+ cdenns(ir,jspin) = cdenns(ir,jspin)+ &
+ cleb(j)*wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)* &
+ thetasnew(ir,ifun)
+ END DO
+ END IF
+ END DO ! JSPIN
+END DO ! J
-DATA vz/'-',' ',' '/
-small(arg) = ABS(arg*tol) < 1.0D0
+deallocate(wr)
+deallocate(qnsi)
+deallocate(pnsi)
+END SUBROUTINE rhooutnew
+SUBROUTINE calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,z,c,e, &
+ rnew,vins,ncheb,npan_tot,rpan_intervall, &
+ jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor,tmat, &
+ use_sratrick,enable_quad_prec)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-18 Time: 14:28:30
-same(ca,cb) = small(1.0D0-ca/cb)
+IMPLICIT NONE
-nfil = ABS(k_fmt_fil)
+INTEGER, INTENT(IN) :: nsra
+INTEGER, INTENT(IN) :: irmdnew
+INTEGER, INTENT(IN OUT) :: nrmaxd
+INTEGER, INTENT(IN) :: lmax
+INTEGER, INTENT(IN) :: nspin
+DOUBLE PRECISION, INTENT(IN) :: z
+DOUBLE PRECISION, INTENT(IN) :: c
+DOUBLE COMPLEX, INTENT(OUT) :: e
+!INTEGER, INTENT(IN) :: lmpotd
+!INTEGER, INTENT(IN OUT) :: lmmaxso
+DOUBLE PRECISION, INTENT(IN) :: rnew(:)
+DOUBLE PRECISION, INTENT(IN) :: vins(:,:,:)
+INTEGER, INTENT(IN) :: ncheb
+INTEGER, INTENT(IN) :: npan_tot
+DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
+INTEGER, INTENT(OUT) :: jlk_index(:)
+DOUBLE COMPLEX, INTENT(IN OUT) :: hlk(:,:)
+DOUBLE COMPLEX, INTENT(IN OUT) :: jlk(:,:)
+DOUBLE COMPLEX, INTENT(IN OUT) :: hlk2(:,:)
+DOUBLE COMPLEX, INTENT(IN OUT) :: jlk2(:,:)
+DOUBLE COMPLEX, INTENT(IN OUT) :: gmatprefactor
+DOUBLE COMPLEX, INTENT(IN OUT) :: tmat(:)
+INTEGER, INTENT(IN OUT) :: use_sratrick
+LOGICAL, INTENT(IN) :: enable_quad_prec
+! construct wavefunctions for spherical potentials
-tol = 1.0D0/tolp
-!----------------------------------------------- set block indices IQ JQ
+! local
+INTEGER :: lmsize,lmsize2,nvec
+INTEGER :: ivec,lval,ir,ispin,lspin,lsra,i,l1,m1,lm1
+INTEGER, allocatable :: jlk_indextemp(:)
+DOUBLE COMPLEX, allocatable :: vll0(:,:,:)
+DOUBLE COMPLEX, allocatable :: vll(:,:,:)
+DOUBLE COMPLEX, allocatable :: rlltemp(:,:,:),ulltemp(:,:,:),slltemp(:,:,:), &
+ hlktemp(:,:),jlktemp(:,:), hlk2temp(:,:),jlk2temp(:,:), &
+ hlknew(:,:),jlknew(:,:)
+DOUBLE COMPLEX, allocatable :: tmattemp(:,:)
+DOUBLE COMPLEX, allocatable :: alpha(:,:)
-IF ( ijq > 1000 ) THEN
- iq = ijq/1000
- jq = ijq - iq*1000
- IF ( iq*n > m .OR. iq*n > m ) THEN
- WRITE (6,99002) ijq,iq,jq,iq*n,jq*n,n,m
- RETURN
- END IF
+lmsize=1
+IF (nsra == 2) THEN
+ lmsize2=2
+ nvec=2
ELSE
- iq = 1
- jq = 1
+ lmsize2=1
+ nvec=1
END IF
+allocate (rlltemp(lmsize2,lmsize,irmdnew))
+allocate (ulltemp(lmsize2,lmsize,irmdnew))
+allocate (slltemp(lmsize2,lmsize,irmdnew))
+allocate (hlktemp(nvec,irmdnew))
+allocate (jlktemp(nvec,irmdnew))
+allocate (hlk2temp(nvec,irmdnew))
+allocate (jlk2temp(nvec,irmdnew))
+allocate (jlk_indextemp(lmsize2))
+allocate (tmattemp(lmsize,lmsize))
+allocate (alpha(lmsize,lmsize))
+allocate (hlknew(nvec*nspin*(lmax+1),irmdnew))
+allocate (jlknew(nvec*nspin*(lmax+1),irmdnew))
-!----------------------------------------------------- copy matrix block
-
-j0 = n*(jq-1)
-DO j = 1,n
- i1 = n*(iq-1)+1
- jp = j0 + j
- CALL zcopy(n,a(i1,jp),1,b(1,j),1)
-END DO
-
-!------------------------------------------------ set up character table
-
-nc = 0
-DO i = 1,26
- nc = nc + 1
- ipt(nc) = 62 + i
-END DO
-DO i = 1,8
- nc = nc + 1
- ipt(nc) = 96 + i
-END DO
-DO i = 10,26
- nc = nc + 1
- ipt(nc) = 96 + i
-END DO
-DO i = 191,218
- nc = nc + 1
- ipt(nc) = i
-END DO
-DO i = 35,38
- nc = nc + 1
- ipt(nc) = i
-END DO
-DO i = 40,42
- nc = nc + 1
- ipt(nc) = i
-END DO
-DO i = 91,93
- nc = nc + 1
- ipt(nc) = i
+DO ivec=1,nvec
+ jlk_indextemp(ivec)=ivec
END DO
-
-!---------------------------------------------------------------- header
-ic0 = ICHAR('0')
-n3 = n/100
-n2 = n/10 - n3*10
-n1 = n - n2*10 - n3*100
-
-IF ( n <= 18 ) THEN
- fmt1 = '(8X,I3,''|'','
- fmt2 = '( 9X,''--|'','
- fmt3 = '( 9X,'' #|'','
- fmt4 = '( 9X,'' |'','
+allocate(vll0(lmsize,lmsize,irmdnew))
+IF (nsra == 2) THEN
+ allocate(vll(2*lmsize,2*lmsize,irmdnew))
ELSE
- fmt1 = '( I4,''|'','
- fmt2 = '( 2X,''--|'','
- fmt3 = '( 2X,'' #|'','
- fmt4 = '( 2X,'' |'','
+ allocate(vll(lmsize,lmsize,irmdnew))
END IF
-
-lf = 11
-l3 = 11
-IF ( mcol == 0 ) THEN
- fmt1 = fmt1(1:lf)//CHAR(ic0+n3)//CHAR(ic0+n2)//CHAR(ic0+n1) &
- //'( 2A1),''|'',I3)'
- fmt2 = fmt2(1:lf)//CHAR(ic0+n3)//CHAR(ic0+n2)//CHAR(ic0+n1) &
- //'(''--''),''|'',I3)'
- fmt3 = fmt3(1:lf)//'60(2X,I2))'
- fmt4 = fmt4(1:lf)//'60(I2,2X))'
- lf = 21
-ELSE
- IF ( mcol == 1 ) THEN
- nk = nint(SQRT(DBLE(n)))
- ELSE IF ( mcol == 2 ) THEN
- nk = nint(SQRT(DBLE(n/2)))
- ELSE IF ( mcol == 3 ) THEN
- nk = 2*nint(SQRT(DBLE(n/2))) - 1
- END IF
- DO k = 1,nk
- IF ( mcol <= 2 ) THEN
- nm = 2*k - 1
+! spin loop
+DO ispin=1,nspin
+
+ lspin=(lmax+1)*(ispin-1)
+ lsra=(lmax+1)*nvec
+! each value of l, the Lippmann-Schwinger equation is solved using
+! the free-potential wavefunctions and potentials corresponding to l-value
+ DO lval=0,lmax
+
+ DO ir=1,irmdnew
+ vll0(lmsize,lmsize,ir)=vins(ir,1,ispin)-2D0*z/rnew(ir)
+ END DO
+
+ IF (nsra == 2) THEN
+ CALL vllmatsra(vll0,vll,rnew,lmsize,irmdnew,nrmaxd, &
+ e,c,lmax,lval,'Ref=0')
ELSE
- nm = 2*((k+1)/2)
+ vll(:,:,:)=vll0(:,:,:)
END IF
- nm2 = nm/10
- nm1 = nm - nm2*10
- nm3 = nm/2
- fmt1 = fmt1(1:lf)//CHAR(ic0+nm2)//CHAR(ic0+nm1) //'( 2A1),''|'','
- fmt2 = fmt2(1:lf)//CHAR(ic0+nm2)//CHAR(ic0+nm1) //'(''--''),''|'','
- IF ( mcol <= 2 ) THEN
- DO mm = 1,nm
- IF ( MOD(mm,2) == MOD(k,2) ) THEN
- fmt3 = fmt3(1:l3)//'2X,'
- fmt4 = fmt4(1:l3)//'I2,'
- ELSE
- fmt3 = fmt3(1:l3)//'I2,'
- fmt4 = fmt4(1:l3)//'2X,'
- END IF
- l3 = l3 + 3
+ jlktemp(1,:)=jlk(lval+1,:)
+ hlktemp(1,:)=hlk(lval+1,:)
+ jlk2temp(1,:)=jlk2(lval+1,:)
+ hlk2temp(1,:)=hlk2(lval+1,:)
+ IF (nsra == 2) THEN
+ jlktemp(2,:)=jlk(lmax+lval+2,:)
+ hlktemp(2,:)=hlk(lmax+lval+2,:)
+ jlk2temp(2,:)=jlk2(lmax+lval+2,:)
+ hlk2temp(2,:)=hlk2(lmax+lval+2,:)
+ END IF
+ CALL sll_global_solutions(rpan_intervall,rnew,vll,slltemp, &
+ ncheb,npan_tot,lmsize,lmsize2,nvec,irmdnew,nvec, &
+ jlk_indextemp,hlktemp,jlktemp,hlk2temp,jlk2temp, &
+ gmatprefactor,use_sratrick,enable_quad_prec,.false.)
+ CALL rll_global_solutions(rpan_intervall,rnew,vll,rlltemp,ulltemp,tmattemp, &
+ ncheb,npan_tot,lmsize,lmsize2,nvec,irmdnew,nvec, &
+ jlk_indextemp,hlktemp,jlktemp,hlk2temp,jlk2temp, &
+ gmatprefactor,use_sratrick,alpha)
+
+ DO ir=1,irmdnew
+ hlknew(lspin+lval+1,ir)=slltemp(1,1,ir)/rnew(ir)
+ jlknew(lspin+lval+1,ir)=rlltemp(1,1,ir)/rnew(ir)
+ END DO
+ IF (nsra == 2) THEN
+ DO ir=1,irmdnew
+ hlknew(lspin+lsra+lval+1,ir)=slltemp(2,1,ir)/rnew(ir)
+ jlknew(lspin+lsra+lval+1,ir)=rlltemp(2,1,ir)/rnew(ir)
END DO
- fmt3 = fmt3(1:l3)//'''|'','
- fmt4 = fmt4(1:l3)//'''|'','
- l3 = l3 + 4
- ELSE
- fmt3 = fmt3(1:lf)//CHAR(ic0+nm3)//'(2X,I2),''|'','
- fmt4 = fmt4(1:lf)//CHAR(ic0+nm3)//'(I2,2X),''|'','
- l3 = l3 + 13
END IF
- lf = lf + 13
- END DO
- IF ( mcol == 2 ) THEN
- fmt1 = fmt1(1:lf)//fmt1(12:lf)
- fmt2 = fmt2(1:lf)//fmt2(12:lf)
- fmt3 = fmt3(1:l3)//fmt3(12:l3)
- fmt4 = fmt4(1:l3)//fmt4(12:l3)
- lf = 2*lf - 11
- l3 = 2*l3 - 11
- END IF
- fmt1 = fmt1(1:lf)//'I3)'
- fmt2 = fmt2(1:lf)//'I3)'
- fmt3 = fmt3(1:l3)//'I3)'
- fmt4 = fmt4(1:l3)//'I3)'
-END IF
-IF ( mlin == 0 ) THEN
- nsl = 1
- ilsep(1) = n
-ELSE IF ( mlin == 1 ) THEN
- nsl = nint(SQRT(DBLE(n)))
- DO il = 1,nsl
- ilsep(il) = il**2
+ tmat(lspin+lval+1)=tmattemp(1,1)
+ END DO ! LMAX
+END DO ! NSPIN
+
+lm1=1
+DO ivec=1,nvec
+ DO i=1,2
+ DO l1=0,lmax
+ DO m1=-l1,l1
+ jlk_index(lm1)=l1+(ivec-1)*nspin*(lmax+1)+(i-1)*(lmax+1)+1
+ lm1=lm1+1
+ END DO
+ END DO
END DO
-ELSE IF ( mlin == 2 ) THEN
- nsl = nint(SQRT(DBLE(n/2)))
- DO il = 1,nsl
- ilsep(il) = il**2
+END DO
+DO ir=1,irmdnew
+ DO l1=1,nvec*(lmax+1)*nspin
+ hlk(l1,ir)=hlknew(l1,ir)
+ jlk(l1,ir)=jlknew(l1,ir)
END DO
- DO il = 1,nsl
- ilsep(nsl+il) = ilsep(nsl) + il**2
+END DO
+IF (nsra == 2) THEN
+ DO ir=1,irmdnew
+ DO l1=1,(lmax+1)*nspin
+ hlk2(l1,ir)=-hlknew(l1+lmax+1,ir)
+ jlk2(l1,ir)=-jlknew(l1+lmax+1,ir)
+ END DO
+ DO l1=nspin*(lmax+1)+1,nvec*(lmax+1)*nspin
+ hlk2(l1,ir)=hlknew(l1-(lmax+1)*nspin,ir)
+ jlk2(l1,ir)=jlknew(l1-(lmax+1)*nspin,ir)
+ END DO
END DO
- nsl = 2*nsl
-ELSE IF ( mlin == 3 ) THEN
- nsl = 2*nint(SQRT(DBLE(n/2))) - 1
- ilsep(1) = 2
- DO k = 2,nsl
- ilsep(k) = ilsep(k-1) + 2*((k+1)/2)
+ELSE
+ DO ir=1,irmdnew
+ DO l1=1,nvec*(lmax+1)*nspin
+ hlk2(l1,ir)=-hlknew(l1,ir)
+ jlk2(l1,ir)=-jlknew(l1,ir)
+ END DO
END DO
END IF
+deallocate (rlltemp)
+deallocate (ulltemp)
+deallocate (slltemp)
+deallocate (hlktemp)
+deallocate (jlktemp)
+deallocate (hlk2temp)
+deallocate (jlk2temp)
+deallocate (jlk_indextemp)
+deallocate (tmattemp)
+deallocate (alpha)
+deallocate (hlknew)
+deallocate (jlknew)
+deallocate (vll0)
+deallocate (vll)
+END SUBROUTINE calcsph
-WRITE (nfil,99001) str(1:lstr)
-IF ( ijq > 1000 ) WRITE (nfil,99003) iq,jq
-WRITE (nfil,fmt3) (i,i=2,n,2)
-WRITE (nfil,fmt4) (i,i=1,n,2)
-WRITE (nfil,FMT=fmt2)
-!------------------------------------------------------------ header end
-nnon0 = 0
-nd = 0
-ctab(0) = ' '
-dtab(0) = 9999D0
-
-DO i = 1,n
- DO j = 1,n
- IF ( .NOT.small(b(i,j)) ) THEN
- nnon0 = nnon0 + 1
- DO id = 1,nd
- IF ( same(b(i,j),+dtab(id)) ) THEN
- iw(j) = +id
- GO TO 50
- END IF
- IF ( same(b(i,j),-dtab(id)) ) THEN
- iw(j) = -id
- GO TO 50
- END IF
- END DO
-!----------------------------------------------------------- new element
- nd = nd + 1
- iw(j) = nd
- dtab(nd) = b(i,j)
- IF ( ABS(dtab(nd)-1.0D0)*tol < 1.0D0 ) THEN
- ctab(nd) = '1'
- ELSE IF ( ABS(dtab(nd)+1.0D0)*tol < 1.0D0 ) THEN
- dtab(nd) = +1.0D0
- ctab(nd) = '1'
- iw(j) = -nd
- ELSE IF ( ABS(dtab(nd)-ci)*tol < 1.0D0 ) THEN
- ctab(nd) = 'i'
- ELSE IF ( ABS(dtab(nd)+ci)*tol < 1.0D0 ) THEN
- dtab(nd) = +ci
- ctab(nd) = 'i'
- iw(j) = -nd
- ELSE
- ctab(nd) = CHAR(ipt(1+MOD((nd+1),nc)))
- END IF
- ELSE
- iw(j) = 0
- END IF
- 50 END DO
-!------------------------------------------------------------ write line
- WRITE (nfil,FMT=fmt1) i, (vz(ISIGN(1,iw(j))),ctab(ABS(iw(j))),j=1, &
- n),i
-
- DO isl = 1,nsl
- IF ( i == ilsep(isl) ) WRITE (nfil,FMT=fmt2)
- END DO
-END DO
+ subroutine rll_global_solutions(rpanbound,rmesh,vll,rll,ull,tllp, &
+ ncheb,npan,lmsize,lmsize2,lbessel,nrmax, &
+ nvec,jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor, &
+ use_sratrick1, &
+ alpha)
+! ************************************************************************
+! radial wave functions by the integral equation method of
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+! which has been extended for KKR using non-sperical potentials.
+! Further information can be found in
+!
+! David Bauer,
+! "Development of a relativistic full-potential first-principles multiple scattering
+! Green function method applied to complex magnetic textures of nano structures
+! at surfaces", PhD Thesis, 2014
+!
+! http://darwin.bth.rwth-aachen.de/opus3/volltexte/2014/4925/
+!
+!
+!
+! ************************************************************************
+! This routine solves the following two equations:
+!
+! ULL(r) = J(r) - PRE * J(r) * int_0^r( dr' r'^2 H2(r') * op(V(r')) * ULL(r') )
+! + PRE * H(r) * int_0^r( dr' r'^2 J2(r') * op(V(r')) * ULL(r') )
+!
+! where the integral int_0^r() runs from 0 to r
+! ************************************************************************
+! Potential matrix : VLL(LMSIZE*NVEC,LMSIZE*NVEC)
+! LMSIZE = LMMAX (number of LM components) x Number of spin components
+! LMSIZE2 = NVEC* LMSIZE
+! NVEC is 2 for a spinor and 1 in case of a non-rel. calculation
+!
+! ************************************************************************
+! Green function prefacor PRE=GMATPREFACTOR (scalar value)
+! tipically \kappa for non-relativistic and M_0 \kappa for SRA
+!
+! ************************************************************************
-!------------------------------------------------------------------ foot
-WRITE (nfil,fmt4) (i,i=1,n,2)
-WRITE (nfil,fmt3) (i,i=2,n,2)
+! ************************************************************************
+! The discretization of the Lippmann-Schwinger equation results in a matrix
+! equation which is solved in this routine. Further information is given
+! in section 5.2.3, page 90 of Bauer, PhD
+!
+! Source terms :
+! right solution: J, H (nvec*lmsize,lmsize) or (lmsize,nvec*lmsize)
+! left solution: J2,H2 (lmsize,nvec*lmsize) or (nvec*lmsize,lmsize)
+!
+! Example:
+! The source term J is for LMSIZE=3 and NVEC=2 given by:
+! J = / jlk(jlk_index(1)) \
+! | 0 jlk(jlk_index(2)) |
+! | 0 0 jlk(jlk_index(3)) |
+! | jlk(jlk_index(4)) |
+! | 0 jlk(jlk_index(5)) |
+! \ 0 0 jlk(jlk_index(6)) /
+!
+! first 3 rows are for the large and the last 3 rows for the small component
+! ************************************************************************
+! Operator op() can be chosen to be a unity or a transpose operation
+! The unity operation is used to calculate the right solution
+! The transpose operation is used to calculate the left solution
+! ************************************************************************
+! RMESH - radial mesh
+! RPANBOUND - panel bounds RPANBOUND(0) left panel border of panel 1
+! RPANBOUND(1) right panel border of panel 1
+! NCHEB - highes chebyshev polynomial
+! number of points per panel = NCHEB + 1
+! NPAN - number of panels
+! LMSIZE - number of colums for the source matrix J etc...
+! LMSIZE2 - number of rows for the source matrix J etc...
+! NRMAX - total number of radial points (NPAN*(NCHEB+1))
+! NVEC - number of LMSIZE*LMSIZE blocks in J (LMSIZE2=NVEC*LMSIZE)
+! ************************************************************************
+implicit none
+ integer :: ncheb ! number of chebyshev nodes
+ integer :: npan ! number of panels
+ integer :: lmsize ! lm-components * nspin
+ integer :: lmsize2 ! lmsize * nvec
+ integer :: nvec ! spinor integer
+ ! nvec=1 non-rel, nvec=2 for sra and dirac
+ integer :: nrmax ! total number of rad. mesh points
+ integer :: LBESSEL, use_sratrick1
-IF ( k_fmt_fil > 0 ) THEN
- WRITE (nfil,99004) (id,ctab(id),dtab(id),id=1,nd)
- WRITE (nfil,99005) nnon0,tolp,n*n - nnon0,tolp
-ELSE
- WRITE (nfil,*) ' '
-END IF
+ double complex,parameter:: ci= (0.0d0,1.0d0), &! complex i
+ cone=(1.0d0,0.0d0),&! 1
+ czero=(0.0d0,0.0d0) ! 0
+ ! running indices
+ integer lm1,lm2
+ integer info,icheb,ipan,mn,nm
-99001 FORMAT (/,8X,a,/)
-99002 FORMAT (/,1X,79('*'),/,10X,'inconsistent call of <CMATSTR>',/,10X, &
- 'argument IJQ =',i8,' implies IQ=',i3,' JQ=',i3,/,10X, &
- 'IQ*N=',i6,' > M or JQ*N=',i6,' > M for N =',i4, &
- ' M=',i4,/,1X,79('*'),/)
-99003 FORMAT (8X,'IQ-JQ-block for IQ = ',i3,' JQ = ',i3,/)
-99004 FORMAT (/,8X,'symbols used:',/,(8X,i3,3X,a1,2X,2F20.12))
-99005 FORMAT (/,8X,i5,' elements >',1PE9.1,/, &
- 8X,i5,' elements <',1PE9.1,/)
-END SUBROUTINE cmatstr
+ ! source terms
+ double complex :: gmatprefactor ! prefactor of green function
+ ! non-rel: = kappa = sqrt e
+ DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
+ JLK(LBESSEL,NRMAX), &
+ HLK2(LBESSEL,NRMAX), &
+ JLK2(LBESSEL,NRMAX)
-FUNCTION ikapmue(kappa,muem05)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:21:58
+ INTEGER JLK_INDEX(2*LMSIZE)
-! ********************************************************************
-! * *
-! * INDEXING OF MATRIX-ELEMENTS: *
-! * *
-! * I = 2*L*(J+1/2) + J + MUE + 1 *
-! * *
-! ********************************************************************
+ double complex :: rll(lmsize2,lmsize,nrmax), & ! reg. fredholm sol.
+ ull(lmsize2,lmsize,nrmax), & ! reg. volterra sol.
+ tllp(lmsize,lmsize), & ! t-matrix
+ vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7
+ ! bauer, phd
+ double complex,allocatable :: &
+ work(:,:), &
+ allp(:,:,:),bllp(:,:,:), & ! eq. 5.9, 5.10 for reg. sol
+ mrnvy(:,:,:),mrnvz(:,:,:), & !
+ mrjvy(:,:,:),mrjvz(:,:,:), & ! eq. 5.19-5.22
+ vhlr(:,:,:), & ! vhlr = h * v (regular sol.)
+ vjlr(:,:,:) ! vjlr = j * v (regular sol.)
+ double complex,allocatable :: yrf(:,:,:,:), zrf(:,:,:,:) !
+ ! chebyshev arrays
+ double precision c1(0:ncheb,0:ncheb),rpanbound(0:npan)
+ double precision cslc1(0:ncheb,0:ncheb), & ! Integration matrix from left ( C*S_L*C^-1 in eq. 5.53)
+ csrc1(0:ncheb,0:ncheb), & ! Same from right ( C*S_R*C^-1 in eq. 5.54)
+ tau(0:ncheb,0:npan), & ! Radial mesh point
+ slc1sum(0:ncheb),rmesh(nrmax),drpan2
-IMPLICIT NONE
+ integer ipiv(0:ncheb,lmsize2)
+ integer,allocatable :: ipiv2(:)
+ integer :: use_sratrick
+ integer,parameter :: directsolv=1
+ double complex alpha(lmsize,lmsize)
-INTEGER, INTENT(IN) :: kappa
-INTEGER, INTENT(IN) :: muem05
+ external zgetrf,zgetrs,zgemm
+ intrinsic abs,atan,cos,dimag,exp,max,min,sin,sqrt
+! ***********************************************************************
+! SRA trick
+! ***********************************************************************
+! on page 68 of Bauer, PhD, a method is described how to speed up the
+! calculations in case of the SRA. A similar approach is implemented
+! here by using Eq. 4.132 and substituting DV from 4.133, and discretising
+! the radial mesh of the Lippmann-Schwinger eq. according to 5.68.
+! The Lippmann-Schwinger equation leads to a matrix inversion
+! problem. The matrix M which needs to be inverted has a special form
+! if the SRA approximation is used:
+!
+! matrix A ( C 0) (same as in eq. 5.68)
+! ( B 1)
+! (C, B are matricies here)
+!
+! inverse of A is (C^-1 0 )
+! (-B C^-1 1 )
+! Thus, it is sufficient to only inverse the matrix C which saves computational
+! time. This is refered to as the SRA trick.
+! ***********************************************************************
+! in future implementation equation 4.134 is supposed to be
+! implemented which should lead to an additional speed-up.
+! ***********************************************************************
-! Dummy arguments
+if ( lmsize==1 ) then
+ use_sratrick=0
+else
+ use_sratrick=use_sratrick1
+end if
+do ipan = 1,npan
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ tau(icheb,ipan) = rmesh(mn)
+ end do
+end do
-INTEGER :: ikapmue
+call chebint(cslc1,csrc1,slc1sum,c1,ncheb)
-! Local variables
+if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
+if(.not.allocated(allp)) allocate( allp(lmsize,lmsize,0:npan), bllp(lmsize,lmsize,0:npan) )
+if(.not.allocated(mrnvy)) allocate( mrnvy(lmsize,lmsize,npan), mrnvz(lmsize,lmsize,npan) )
+if(.not.allocated(mrjvy)) allocate( mrjvy(lmsize,lmsize,npan), mrjvz(lmsize,lmsize,npan) )
+if(.not.allocated(vjlr)) allocate( vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb) )
-INTEGER :: IABS
-INTEGER :: jp05,l
+if(.not.allocated(yrf)) allocate( yrf(lmsize2,lmsize,0:ncheb,npan) )
+if(.not.allocated(zrf)) allocate( zrf(lmsize2,lmsize,0:ncheb,npan) )
-jp05 = IABS(kappa)
+ do ipan = 1, npan
-IF ( kappa < 0 ) THEN
- l = -kappa - 1
-ELSE
- l = kappa
-END IF
+ drpan2 = (rpanbound(ipan)-rpanbound(ipan-1))/2.0d0 ! *(b-a)/2 in eq. 5.53, 5.54
+ call rll_local_solutions(vll,tau(0,ipan),drpan2,cslc1,slc1sum,mrnvy(1,1,ipan),&
+ mrnvz(1,1,ipan),mrjvy(1,1,ipan),mrjvz(1,1,ipan),yrf(1,1,0,ipan), &
+ zrf(1,1,0,ipan),ncheb,ipan,lmsize,lmsize2,nrmax,nvec,jlk_index,hlk,jlk,hlk2,&
+ jlk2,gmatprefactor,lbessel,use_sratrick1)
-ikapmue = 2*l*jp05 + jp05 + muem05 + 1
+ end do ! ipan
-END FUNCTION ikapmue
+! ***********************************************************************
+! calculate A(M), B(M), C(M), D(M)
+! according to 5.17-5.18 (regular solution) of Bauer PhD
+! C,D are calculated accordingly for the irregular solution
+! (starting condition: A(0) = 1, B(0) = 0, C(MMAX) = 0 and D(MMAX) = 1)
+! ***********************************************************************
+! regular
+do lm2 = 1,lmsize
+ do lm1 = 1,lmsize
+ bllp(lm1,lm2,0) = czero
+ allp(lm1,lm2,0) = czero
+ end do
+end do
-SUBROUTINE ikmlin(iprint,nsollm,ikm1lin,ikm2lin,nlmax,nmuemax, &
- linmax,nl)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:05:20
+do lm1 = 1,lmsize
+ allp(lm1,lm1,0) = cone
+end do
-! ********************************************************************
-! * *
-! * SETUP TABLE OF INDICES IKM(INT) *
-! * *
-! * IKM IS STANDARD INDEX IN (KAPPA,MUE)-REPRESENTATION *
-! * IKM = 2*L*(J+1/2) + J + MUE + 1 *
-! * *
-! * INT NUMBERS LINEARLY ONLY NON-VANISHING ELEMENTS OF M-SS *
-! * USED TO CALCULATE DOS ... *
-! * *
-! ********************************************************************
+do ipan = 1,npan
+ call zcopy(lmsize*lmsize,allp(1,1,ipan-1),1,allp(1,1,ipan),1)
+ call zcopy(lmsize*lmsize,bllp(1,1,ipan-1),1,bllp(1,1,ipan),1)
+ call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvy(1,1,ipan), &
+ lmsize,allp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvz(1,1,ipan), &
+ lmsize,bllp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvy(1,1,ipan), &
+ lmsize,allp(1,1,ipan-1),lmsize,cone,bllp(1,1,ipan),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvz(1,1,ipan), &
+ lMSIZE,BLLP(1,1,IPAN-1),LMSIZE,CONE,BLLP(1,1,IPAN),LMSIZE)
+end do
-IMPLICIT NONE
+! ***********************************************************************
+! determine the regular solution ull by using 5.14
+! ***********************************************************************
+do ipan = 1,npan
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ call zgemm('n','n',lmsize2,lmsize,lmsize,cone,yrf(1,1,icheb,ipan), &
+ lmsize2,allp(1,1,ipan-1),lmsize,czero,ull(1,1,mn),lmsize2)
+ call zgemm('n','n',lmsize2,lmsize,lmsize,cone,zrf(1,1,icheb,ipan), &
+ lmsize2,bllp(1,1,ipan-1),lmsize,cone,ull(1,1,mn),lmsize2)
+ end do
+end do
-INTEGER, INTENT(IN) :: iprint
-INTEGER, INTENT(IN) :: nsollm(nlmax,nmuemax)
-INTEGER, INTENT(OUT) :: ikm1lin(linmax)
-INTEGER, INTENT(OUT) :: ikm2lin(linmax)
-INTEGER, INTENT(IN) :: nlmax
-INTEGER, INTENT(IN) :: nmuemax
-INTEGER, INTENT(IN) :: linmax
-INTEGER, INTENT(IN) :: nl
+! ***********************************************************************
+! next part converts the volterra solution u of equation (5.7) to
+! the fredholm solution r by employing eq. 4.122 and 4.120 of bauer, phd
+! and the t-matrix is calculated
+! ***********************************************************************
+call zgetrf(lmsize,lmsize,allp(1,1,npan),lmsize,ipiv,info) !invert alpha
+call zgetri(lmsize,allp(1,1,npan),lmsize,ipiv,work,lmsize*lmsize,info) !invert alpha -> transformation matrix rll=alpha^-1*rll
-! Dummy arguments
+ alpha=allp(:,:,npan) ! LLY
+! calculation of the t-matrix
+call zgemm('n','n',lmsize,lmsize,lmsize,cone/gmatprefactor,bllp(1,1,npan), & ! calc t-matrix tll = bll*alpha^-1
+ lmsize,allp(1,1,npan),lmsize,czero,tllp,lmsize)
+do nm = 1,nrmax
+call zgemm('n','n',lmsize2,lmsize,lmsize,cone,ull(1,1,nm), &
+ lmsize2,allp(1,1,npan),lmsize,czero,rll(1,1,nm),lmsize2)
+end do
+if(allocated(work)) deallocate( work )
+if(allocated(allp)) deallocate( allp, bllp )
+if(allocated(mrnvy)) deallocate( mrnvy, mrnvz )
+if(allocated(mrjvy)) deallocate( mrjvy, mrjvz )
+if(allocated(vjlr)) deallocate( vjlr, vhlr )
-! Local variables
+if(allocated(yrf)) deallocate( yrf )
+if(allocated(zrf)) deallocate( zrf )
-INTEGER :: i,il,imue,k1,k2,kap(2),l,lin,muem05,nsol
-!INTEGER :: ikapmue
+end subroutine rll_global_solutions
-lin = 0
+ subroutine rll_local_solutions(vll,tau,drpan2,cslc1,slc1sum, &
+ mrnvy,mrnvz,mrjvy,mrjvz, &
+ yrf,zrf, &
+ ncheb,ipan,lmsize,lmsize2,nrmax, &
+ nvec,jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor, &
+ LBESSEL,use_sratrick1)
+implicit none
+ integer :: ncheb ! number of chebyshev nodes
+ integer :: lmsize ! lm-components * nspin
+ integer :: lmsize2 ! lmsize * nvec
+ integer :: nvec ! spinor integer
+! nvec=1 non-rel, nvec=2 for sra and dirac
+ integer :: nrmax ! total number of rad. mesh points
-DO il = 1,nl
- l = il - 1
- muem05 = -il - 1
- kap(1) = -l - 1
- kap(2) = +l
-
- DO imue = 1,2*il
- muem05 = muem05 + 1
- nsol = nsollm(il,imue)
-
- DO k2 = 1,nsol
- DO k1 = 1,nsol
- lin = lin + 1
- ikm1lin(lin) = ikapmue(kap(k1),muem05)
- ikm2lin(lin) = ikapmue(kap(k2),muem05)
- END DO
- END DO
-
- END DO
-END DO
+ integer :: LBESSEL, use_sratrick1 ! dimensions etc., needed only for host code interface
-IF ( iprint < 2 ) RETURN
-WRITE (6,FMT='('' INT='',I3,'' IKM=('',I3,'','',I3,'')'')') &
- (i,ikm1lin(i),ikm2lin(i),i=1,lin)
-END SUBROUTINE ikmlin
-!***********************************************************************
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:26:23
+ double complex,parameter:: cone=(1.0d0,0.0d0),czero=(0.0d0,0.0d0)
+! running indices
+ integer ivec, ivec2
+ integer l1,l2,lm1,lm2,lm3
+ integer info,icheb2,icheb,ipan,mn,nplm
-SUBROUTINE splint_real(xa,ya,y2a,n,x,y,yderiv)
+! source terms
+ double complex :: gmatprefactor ! prefactor of green function
+! non-rel: = kappa = sqrt e
-IMPLICIT NONE
+ DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
+ JLK(LBESSEL,NRMAX), &
+ HLK2(LBESSEL,NRMAX), &
+ JLK2(LBESSEL,NRMAX)
-REAL*8, INTENT(IN) :: xa(*)
-REAL*8, INTENT(IN) :: ya(*)
-REAL*8, INTENT(IN OUT) :: y2a(*)
-INTEGER, INTENT(IN) :: n
-REAL*8, INTENT(IN) :: x
-REAL*8, INTENT(OUT) :: y
-REAL*8, INTENT(OUT) :: yderiv
-
-
-! Given the arrays xa(1:n) and ya(1:n) of length n, which tabulate a
-! function (with the xai's in order), and given the array y2a(1:n), which
-! is the output from spline above, and given a value of x, this routine
-! returns a cubic-spline interpolated value y and the derivative yderiv.
-! Taken from "Numerical Recipes in Fortran 77", W.H.Press et al.
-INTEGER :: k,khi,klo
-REAL*8 a,b,h
-! We will nd the right place in the table by means of bisection.
-! This is optimal if sequential calls to this routine are at random
-! values of x. If sequential calls are in order, and closely
-! spaced, one would do better to store previous values of
-! klo and khi and test if they remain appropriate on the
-! next call.
-klo=1
-khi=n
-1 IF (khi-klo > 1) THEN
- k=(khi+klo)/2
- IF(xa(k) > x)THEN
- khi=k
- ELSE
- klo=k
- END IF
- GO TO 1
-END IF
-! klo and khi now bracket the input value of x.
-h=xa(khi)-xa(klo)
-! The xa's must be distinct.
-IF (h == 0.d0) PAUSE 'bad xa input in splint'
-! Cubic spline polynomial is now evaluated.
-a = (xa(khi)-x)/h
-b = (x-xa(klo))/h
-y = a*ya(klo) + b*ya(khi) + &
- ((a**3-a)*y2a(klo)+(b**3-b)*y2a(khi)) * (h**2)/6.d0
-yderiv = (ya(khi)-ya(klo))/h - &
- ((3.d0*a*a-1.d0)*y2a(klo) - (3.d0*b*b-1.d0)*y2a(khi))*h/6.d0
-RETURN
-END SUBROUTINE splint_real
+ INTEGER JLK_INDEX(2*LMSIZE)
-SUBROUTINE interpolspline(rmesh,rmeshnew,vpot,vpotnew, &
- nrmax,nrmaxnew)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:05:24
-
-IMPLICIT NONE
-!interface
-INTEGER :: nrmax
-INTEGER :: nrmaxnew
-DOUBLE PRECISION :: rmesh(nrmax)
-DOUBLE PRECISION :: rmeshnew(nrmaxnew)
-DOUBLE PRECISION :: vpot(nrmax)
-DOUBLE PRECISION :: vpotnew(nrmaxnew)
-!local
-DOUBLE PRECISION :: maxa
-DOUBLE PRECISION :: spline(nrmax)
-DOUBLE PRECISION :: parsum, parsumderiv,r0
-INTEGER :: ir
-maxa = 1.d35
-CALL spline_real(nrmax,rmesh,vpot,nrmax,maxa,maxa,spline)
-! CALL SPLINE(IRMDJJ,R,VM2Z,NR,maxa,maxa,VM2ZB)
-
-DO ir = 1,nrmaxnew
- r0 = rmeshnew(ir)
- CALL splint_real(rmesh,vpot,spline,nrmax,r0,parsum,parsumderiv)
- vpotnew(ir) = parsum
-END DO
-END SUBROUTINE interpolspline
+ double complex :: vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7
+
+ double complex :: &
+ mrnvy(lmsize,lmsize),mrnvz(lmsize,lmsize), &
+ mrjvy(lmsize,lmsize),mrjvz(lmsize,lmsize), &
+ yrf(lmsize2,lmsize,0:ncheb), &
+ zrf(lmsize2,lmsize,0:ncheb)
+ double complex :: &
+ slv(0:ncheb,lmsize2,0:ncheb,lmsize2), &
+ slv1(0:ncheb,lmsize,0:ncheb,lmsize), &
+ yrll1(0:ncheb,lmsize,lmsize), zrll1(0:ncheb,lmsize,lmsize), &
+ yrll2(0:ncheb,lmsize,lmsize), zrll2(0:ncheb,lmsize,lmsize), &
+ yrll(0:ncheb,lmsize2,lmsize), zrll(0:ncheb,lmsize2,lmsize), &
+ vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb), &
+ vjlr_yrll1(lmsize,lmsize), vhlr_yrll1(lmsize,lmsize), &
+ vjlr_zrll1(lmsize,lmsize), vhlr_zrll1(lmsize,lmsize), &
+ yrll1temp(lmsize,lmsize), zrll1temp(lmsize,lmsize)
+
+ double complex :: &
+ jlmkmn(0:ncheb,lmsize2,0:ncheb), &
+ hlmkmn(0:ncheb,lmsize2,0:ncheb)
+
+! chebyshev arrays
+ double complex zslc1sum(0:ncheb)
+ double precision drpan2
+ double precision cslc1(0:ncheb,0:ncheb), & ! Integration matrix from left ( C*S_L*C^-1 in eq. 5.53)
+ tau(0:ncheb), & ! Radial mesh point
+ slc1sum(0:ncheb),taucslcr,tau_icheb
+ double complex :: gf_tau_icheb
-SUBROUTINE strsmat(lmax,cgc,srrel,nrrel,irrel,nkmmax,nkmpmax)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:05:34
-
-! ********************************************************************
-! * *
-! * INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM *
-! * RELATIVISTIC TO REAL SPERICAL HARM. REPRESENTATION *
-! * *
-! * ONLY THE NON-0 ELEMENTS OF THE MATRIX ARE STORED *
-! * *
-! * 25/10/95 HE proper convention of trans. matrix introduced *
-! ********************************************************************
+ integer ipiv(0:ncheb,lmsize2)
+ integer :: use_sratrick
-IMPLICIT NONE
+ external zgetrf,zgetrs,zgemm
-INTEGER, INTENT(IN) :: lmax
-REAL*8, INTENT(IN) :: cgc(nkmpmax,2)
-COMPLEX*16, INTENT(OUT) :: srrel(2,2,nkmmax)
-INTEGER, INTENT(OUT) :: nrrel(2,nkmmax)
-INTEGER, INTENT(OUT) :: irrel(2,2,nkmmax)
-INTEGER, INTENT(IN) :: nkmmax
-INTEGER, INTENT(IN) :: nkmpmax
+if ( lmsize==1 ) then
+ use_sratrick=0
+else
+ use_sratrick=use_sratrick1
+end if
-! PARAMETER definitions
+! initialization
+
+ vhlr=czero
+ vjlr=czero
-COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
-COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
-COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
+ if (use_sratrick==0) then
+ yrll=czero
+ zrll=czero
+ else
+ yrll1=czero
+ zrll1=czero
+ yrll2=czero
+ zrll2=czero
+ end if
-! Dummy arguments
+!---------------------------------------------------------------------
+! 1. prepare VJLR, VNL, VHLR, which appear in the integrands
+! TAU(K,IPAN) is used instead of TAU(K,IPAN)**2, which directly gives
+! RLL(r) and SLL(r) multiplied with r. TAU is the radial mesh.
+!
+! 2. prepare the source terms YR, ZR, YI, ZI
+! because of the conventions used by
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+! a factor sqrt(E) is included in the source terms
+! this factor is removed by the definition of ZSLC1SUM given below
+!
+!vjlr = \kappa * J * V = \kappa * r * j *V
+!vhlr = \kappa * H * V = \kappa * r * h *V
+!
+! i.e. prepare terms kappa*J*DV, kappa*H*DV appearing in 5.11, 5.12.
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ tau_icheb = tau(icheb)
+ gf_tau_icheb = gmatprefactor*tau_icheb
+ do ivec2=1,nvec
+ do lm2 = 1,lmsize
+ do ivec=1,nvec
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1+lmsize*(ivec-1) )
+ vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
+ gf_tau_icheb*jlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
+ vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
+ gf_tau_icheb*hlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
+ end do
+ end do
+ end do
+ end do
+! calculation of the J (and H) matrix according to equation 5.69 (2nd eq.)
+ if ( use_sratrick==0 ) then
+ do ivec=1,nvec ! index for large/small component
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1+lmsize*(ivec-1) )
+ yrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau_icheb*jlk(l1,mn)
+ zrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau_icheb*hlk(l1,mn)
+ end do
+ end do !ivec=1,nvec
+ elseif ( use_sratrick==1 ) then
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1+lmsize*(1-1) )
+ l2 = jlk_index( lm1+lmsize*(2-1) )
+ yrll1(icheb,lm1+lmsize*(1-1),lm1) = tau_icheb*jlk(l1,mn)
+ zrll1(icheb,lm1+lmsize*(1-1),lm1) = tau_icheb*hlk(l1,mn)
+ yrll2(icheb,lm1+lmsize*(1-1),lm1) = tau_icheb*jlk(l2,mn)
+ zrll2(icheb,lm1+lmsize*(1-1),lm1) = tau_icheb*hlk(l2,mn)
+ end do
+ end if
+ end do ! icheb
+! calculation of A in 5.68
+ if ( use_sratrick==0 ) then
+ do icheb2 = 0,ncheb
+ do icheb = 0,ncheb
+ taucslcr = tau(icheb)*cslc1(icheb,icheb2)*drpan2
+ mn = ipan*ncheb + ipan - icheb
+ do lm2 = 1,lmsize2
+ do ivec=1,nvec
+ do lm3 = 1,lmsize
+ lm1=lm3+(ivec-1)*lmsize
+ l1 = jlk_index(lm1)
+ slv(icheb,lm1,icheb2,lm2) = &
+ taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
+ -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
+ end do
+ end do
+ end do
+ end do
+ end do
+ do lm1 = 1,lmsize2
+ do icheb = 0,ncheb
+ slv(icheb,lm1,icheb,lm1) = slv(icheb,lm1,icheb,lm1) + 1.d0
+ end do
+ end do
+ elseif ( use_sratrick==1 ) then
+ do icheb2 = 0,ncheb
+ do icheb = 0,ncheb
+ taucslcr = tau(icheb)*cslc1(icheb,icheb2)*drpan2
+ mn = ipan*ncheb + ipan - icheb
+ do lm1 = 1,lmsize
+ l1 = jlk_index(lm1)
+ jlmkmn(icheb,lm1,icheb2) = - taucslcr*jlk(l1,mn)
+ hlmkmn(icheb,lm1,icheb2) = - taucslcr*hlk(l1,mn)
+ end do
+ end do
+ end do
+ do lm2 = 1,lmsize
+ do icheb2 = 0,ncheb
+ do lm1 = 1,lmsize
+ do icheb = 0,ncheb
+ slv1(icheb,lm1,icheb2,lm2) = &
+ -jlmkmn(icheb,lm1,icheb2)*vhlr(lm1,lm2,icheb2) &
+ +hlmkmn(icheb,lm1,icheb2)*vjlr(lm1,lm2,icheb2)
+ end do
+ end do
+ end do
+ end do
-! Local variables
+ do lm1 = 1,lmsize
+ do icheb = 0,ncheb
+ slv1(icheb,lm1,icheb,lm1) = slv1(icheb,lm1,icheb,lm1) + 1.d0
+ end do
+ end do
-COMPLEX*16 crel(nkmmax,nkmmax),rc(nkmmax,nkmmax), rrel(nkmmax,nkmmax)
-INTEGER :: i,ikm,j,jp05,k,l,lam,lm,lnr,lr,m,muem05,muep05,nk,nkm,nlm, ns1,ns2
-REAL*8 w
+ else
+ stop '[rllsll] error in inversion'
+ end if
-nk = 2*(lmax+1) + 1
-nlm = (lmax+1)**2
-nkm = 2*nlm
-! ===================================================
-! INDEXING:
-! IKM = L*2*(J+1/2) + J + MUE + 1
-! LM = L*(L+1) + M + 1
-! ===================================================
+!-------------------------------------------------------
+! determine the local solutions
+! solve the equations SLV*YRLL=S and SLV*ZRLL=C
+! and SRV*YILL=C and SRV*ZILL=S
+! i.e., solve system A*U=J, see eq. 5.68.
-! ----------------------------------------------------------------------
-! CREL transforms from COMPLEX (L,M,S) to (KAP,MUE) - representation
-! |LAM> = sum[LC] |LC> * CREL(LC,LAM)
-! ----------------------------------------------------------------------
-CALL cinit(nkmmax*nkmmax,crel)
-
-lm = 0
-DO lnr = 0,lmax
- DO m = -lnr,lnr
- lm = lm + 1
-
- ikm = 0
- DO k = 1,nk
- l = k/2
- IF ( 2*l == k ) THEN
- jp05 = l
- ELSE
- jp05 = l + 1
- END IF
-
- DO muem05 = -jp05,(jp05-1)
- muep05 = muem05 + 1
- ikm = ikm + 1
-
- IF ( l == lnr ) THEN
- IF ( muep05 == m ) crel(lm,ikm) = cgc(ikm,1)
- IF ( muem05 == m ) crel(lm+nlm,ikm) = cgc(ikm,2)
- END IF
-
- END DO
- END DO
-
- END DO
-END DO
-
-! ----------------------------------------------------------------------
-! RC transforms from REAL to COMPLEX (L,M,S) - representation
-! |LC> = sum[LR] |LR> * RC(LR,LC)
-! ----------------------------------------------------------------------
-CALL cinit(nkmmax*nkmmax,rc)
-
-w = 1.0D0/SQRT(2.0D0)
-
-DO l = 0,lmax
- DO m = -l,l
- i = l*(l+1) + m + 1
- j = l*(l+1) - m + 1
-
- IF ( m < 0 ) THEN
- rc(i,i) = -ci*w
- rc(j,i) = w
- rc(i+nlm,i+nlm) = -ci*w
- rc(j+nlm,i+nlm) = w
- END IF
- IF ( m == 0 ) THEN
- rc(i,i) = c1
- rc(i+nlm,i+nlm) = c1
- END IF
- IF ( m > 0 ) THEN
- rc(i,i) = w*(-1.0D0)**m
- rc(j,i) = ci*w*(-1.0D0)**m
- rc(i+nlm,i+nlm) = w*(-1.0D0)**m
- rc(j+nlm,i+nlm) = ci*w*(-1.0D0)**m
- END IF
- END DO
-END DO
-
-! ----------------------------------------------------------------------
-! RREL transforms from REAL (L,M,S) to (KAP,MUE) - representation
-! |LAM> = sum[LR] |LR> * RREL(LR,LAM)
-! ----------------------------------------------------------------------
-CALL zgemm('N','N',nkm,nkm,nkm,c1,rc,nkmmax,crel,nkmmax,c0,rrel, nkmmax)
+ if ( use_sratrick==0 ) then
+ nplm = (ncheb+1)*lmsize2
-! ---------------------------------------------------
-! store the elements of RREL
-! ---------------------------------------------------
-DO lam = 1,nkm
- ns1 = 0
- ns2 = 0
-
- DO lr = 1,2*nlm
- IF ( CDABS(rrel(lr,lam)) > 1D-6 ) THEN
- IF ( lr <= nlm ) THEN
- ns1 = ns1 + 1
- IF ( ns1 > 2 ) STOP ' IN <STRSMAT> NS1 > 2'
- srrel(ns1,1,lam) = rrel(lr,lam)
- irrel(ns1,1,lam) = lr
- ELSE
- ns2 = ns2 + 1
- IF ( ns2 > 2 ) STOP ' IN <STRSMAT> NS2 > 2'
- srrel(ns2,2,lam) = rrel(lr,lam)
- irrel(ns2,2,lam) = lr - nlm
- END IF
- END IF
- END DO
-
- nrrel(1,lam) = ns1
- nrrel(2,lam) = ns2
-END DO
+ call zgetrf(nplm,nplm,slv,nplm,ipiv,info)
+ if (info/=0) stop 'rllsll: zgetrf'
+ call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,yrll,nplm,info)
+ call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,zrll,nplm,info)
-END SUBROUTINE strsmat
+ elseif ( use_sratrick==1 ) then
+ nplm = (ncheb+1)*lmsize
+ call zgetrf(nplm,nplm,slv1,nplm,ipiv,info)
+ call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,yrll1,nplm,info)
+ call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,zrll1,nplm,info)
-!***********************************************************************
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-01 Time: 12:22:03
+ do icheb2 = 0,ncheb
+ do lm2 = 1,lmsize
+ do lm1 = 1,lmsize
+ yrll1temp(lm1,lm2) = yrll1(icheb2,lm1,lm2)
+ zrll1temp(lm1,lm2) = zrll1(icheb2,lm1,lm2)
+ end do
+ end do
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
+ lmsize,yrll1temp,lmsize,czero,vhlr_yrll1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
+ lmsize,zrll1temp,lmsize,czero,vhlr_zrll1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
+ lmsize,yrll1temp,lmsize,czero,vjlr_yrll1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
+ lmsize,zrll1temp,lmsize,czero,vjlr_zrll1,lmsize)
-SUBROUTINE spline_real(nmax,x,y,n,yp1,ypn,y2)
+ do icheb = 0,ncheb
+ taucslcr = - tau(icheb)*cslc1(icheb,icheb2)*drpan2
+ mn = ipan*ncheb + ipan - icheb
+ do lm2 = 1,lmsize
+ do lm3 = 1,lmsize
+ lm1=lm3+lmsize
+ l1 = jlk_index(lm1)
-IMPLICIT NONE
+ yrll2(icheb,lm3,lm2) = &
+ yrll2(icheb,lm3,lm2) + &
+ taucslcr*(jlk(l1,mn)*vhlr_yrll1(lm3,lm2) &
+ -hlk(l1,mn)*vjlr_yrll1(lm3,lm2))
-INTEGER, INTENT(IN) :: nmax
-REAL*8, INTENT(IN) :: x(nmax)
-REAL*8, INTENT(IN) :: y(nmax)
-INTEGER, INTENT(IN) :: n
-REAL*8, INTENT(IN OUT) :: yp1
-REAL*8, INTENT(IN OUT) :: ypn
-REAL*8, INTENT(OUT) :: y2(nmax)
-
-
-! REAL*8 x(NMAX)
-! COMPLEX yp1,ypn,y(NMAX),y2(NMAX)
-! Given arrays x(1:n) and y(1:n) containing a tabulated function,
-! i.e., y i = f(xi), with x1<x2<...<xN , and given values yp1 and ypn
-! for the 1rst derivative of the interpolating function at points
-! 1 and n, respectively, this routine returns an array y2(1:n) of
-! length n which contains the second derivatives of the interpolating
-! function at the tabulated points xi.
-! If yp1 and/or ypn are equal to 1.e30 or larger, the routine is
-! signaled to set the corresponding boundary condition for a natural
-! spline, with zero second derivative on that boundary.
-! Parameter: NMAX is the largest anticipated value of n.
-! Taken from "Numerical Recipes in Fortran 77", W.H.Press et al.
-INTEGER :: i,k
-REAL*8 p,qn,sig,un,u(nmax)
-! COMPLEX p,qn,sig,un,u(NMAX)
-
-IF (n > nmax) STOP 'SPLINE: n > NMAX.'
-IF (ABS(yp1) > 0.99D30) THEN
-! The lower boundary condition is set either to be "natural"
- y2(1) = 0.d0
- u(1) = 0.d0
-ELSE
-! or else to have a specified first derivative.
- y2(1) = -0.5D0
- u(1)=(3.d0/(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-yp1)
-END IF
+ zrll2(icheb,lm3,lm2) = &
+ zrll2(icheb,lm3,lm2) + &
+ taucslcr*(jlk(l1,mn)*vhlr_zrll1(lm3,lm2) &
+ -hlk(l1,mn)*vjlr_zrll1(lm3,lm2))
-DO i = 2,n-1
-! This is the decomposition loop of the tridiagonal algorithm. y2 and u
-! are used for temporary storage of the decomposed factors.
- sig = (x(i)-x(i-1)) / (x(i+1)-x(i-1))
- p = sig * y2(i-1) + 2.d0
- y2(i) = (sig-1.d0)/p
- u(i)=(6.d0*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1)) &
- /(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1)) / p
-END DO
+ end do
+ end do
+ end do
+ end do
-IF (ABS(ypn) > 0.99D30) THEN
-! The upper boundary condition is set either to be "natural"
- qn = 0.d0
- un = 0.d0
-ELSE
-! or else to have a specified 1rst derivative.
- qn = 0.5D0
- un = (3.d0/(x(n)-x(n-1)))*(ypn-(y(n)-y(n-1))/(x(n)-x(n-1)))
-END IF
-y2(n) = (un-qn*u(n-1)) / (qn*y2(n-1)+1.d0)
-DO k = n-1,1,-1
-! This is the backsubstitution loop of the tridiagonal algorithm.
- y2(k)=y2(k)*y2(k+1)+u(k)
-END DO
+ else
+ stop '[rllsll] error in inversion'
+ end if
-RETURN
-END SUBROUTINE spline_real
+! Reorient indices for later use
+ if ( use_sratrick==0 ) then
+ do icheb = 0,ncheb
+ do lm2 = 1,lmsize
+ do lm1 = 1,lmsize2
+ yrf(lm1,lm2,icheb) = yrll(icheb,lm1,lm2)
+ zrf(lm1,lm2,icheb) = zrll(icheb,lm1,lm2)
+ end do
+ end do
+ end do
+ elseif ( use_sratrick==1 ) then
-SUBROUTINE tmat_newsolver(ie,nspin,lmax,zat,socscale, &
- ez,nsra,cleb,icleb,iend,ncheb,npan_tot, &
- rpan_intervall,ipan_intervall, &
- rnew,vinsnew,theta,phi,ipot, &
- ! lly, &
- lmpotd,irmd_new,TmatN,soc) ! new input parameters
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-18 Time: 14:58:02
-
-#ifdef cpp_omp
-!use omp_lib ! necessary for omp functions
-#endif
-#ifdef cpp_mpi
-!use mpi
-#endif
-!use mod_mympi, only: myrank, nranks, master
-#ifdef cpp_mpi
-! & ,distribute_linear_on_tasks
-#endif
-!use mod_types, only: t_tgmat,t_inc,t_mpi_c_grid,init_tgmat, &
-! t_lloyd,init_tlloyd
-
-!!use JijDij_mod, only: type_dtmatJijDij, init_t_dtmatJij_at, calc_dtmatJij
+ do icheb = 0,ncheb
+ do lm2 = 1,lmsize
+ do lm1 = 1,lmsize
+ yrf(lm1,lm2,icheb) = yrll1(icheb,lm1,lm2)
+ zrf(lm1,lm2,icheb) = zrll1(icheb,lm1,lm2)
+ yrf(lm1+lmsize,lm2,icheb) = yrll2(icheb,lm1,lm2)
+ zrf(lm1+lmsize,lm2,icheb) = zrll2(icheb,lm1,lm2)
+ end do
+ end do
+ end do
-IMPLICIT NONE
+ end if
-INTEGER, INTENT(IN) :: ie
-!INTEGER, INTENT(IN) :: ielast
-INTEGER, INTENT(IN) :: nspin
-INTEGER, INTENT(IN) :: lmax
-!DOUBLE PRECISION, INTENT(IN) :: rmesh(:)
-DOUBLE PRECISION, INTENT(IN) :: zat
-DOUBLE PRECISION, INTENT(IN) :: socscale
-DOUBLE COMPLEX, INTENT(IN) :: ez(:)
-INTEGER, INTENT(IN) :: nsra
-DOUBLE PRECISION, INTENT(IN) :: cleb(:)
-INTEGER, INTENT(IN) :: icleb(:,:)
-INTEGER, INTENT(IN) :: iend
-INTEGER, INTENT(IN) :: ncheb
-INTEGER, INTENT(IN) :: npan_tot
-DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
-INTEGER, INTENT(IN) :: ipan_intervall(0:)
-DOUBLE PRECISION, INTENT(IN) :: rnew(:)
-DOUBLE PRECISION, INTENT(IN) :: vinsnew(:,:,:)
-DOUBLE PRECISION, INTENT(IN) :: theta
-DOUBLE PRECISION, INTENT(IN) :: phi
-!INTEGER, INTENT(IN) :: i1
-INTEGER, INTENT(IN) :: ipot
-!INTEGER, INTENT(IN) :: lly
-!DOUBLE COMPLEX, INTENT(IN) :: deltae
-INTEGER, INTENT(IN) :: lmpotd
-!INTEGER, INTENT(IN) :: lmaxd
-INTEGER, INTENT(IN) :: irmd_new
-DOUBLE COMPLEX, INTENT(OUT) :: TmatN(:,:)
-LOGICAL, INTENT(IN) :: soc
-!INCLUDE 'inc.p'
+! Calculation of eq. 5.19-5.22
+ do icheb = 0,ncheb
+ zslc1sum(icheb) = slc1sum(icheb)*drpan2
+ end do
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
+ lmsize,yrf(1,1,0),lmsize2,czero,mrnvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
+ lmsize,yrf(1,1,0),lmsize2,czero,mrjvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
+ lmsize,zrf(1,1,0),lmsize2,czero,mrnvz,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
+ lmsize,zrf(1,1,0),lmsize2,czero,mrjvz,lmsize)
+ do icheb = 1,ncheb
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
+ lmsize,yrf(1,1,icheb),lmsize2,cone,mrnvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
+ lmsize,yrf(1,1,icheb),lmsize2,cone,mrjvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
+ lmsize,zrf(1,1,icheb),lmsize2,cone,mrnvz,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
+ lmsize,zrf(1,1,icheb),lmsize2,cone,mrjvz,lmsize)
+ end do
-INTEGER :: lmmaxd
-INTEGER :: lmmaxso
-INTEGER :: nrmaxd
+end subroutine rll_local_solutions
-DOUBLE COMPLEX eryd
+ SUBROUTINE sll_global_solutions(RPANBOUND,RMESH,VLL,SLL, &
+ NCHEB,NPAN,LMSIZE,LMSIZE2,LBESSEL,NRMAX, &
+ NVEC,JLK_INDEX,HLK,JLK,HLK2,JLK2,GMATPREFACTOR, &
+ USE_SRATRICK1,enable_quad_prec,new_sll)
+! ************************************************************************
+! radial wave functions by the integral equation method of
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+! which has been extended for KKR using non-sperical potentials.
+! Further information can be found in
+!
+! David Bauer,
+! "Development of a relativistic full-potential first-principles multiple scattering
+! Green function method applied to complex magnetic textures of nano structures
+! at surfaces", PhD Thesis, 2014
+!
+! http://darwin.bth.rwth-aachen.de/opus3/volltexte/2014/4925/
+!
+!
+!
+! ************************************************************************
+! This routine solves the following equation:
+!
+! SLL(r) = H(r) - PRE * H(r) * int( dr' r'^2 H2(r') * op(V(r')) * RLL(r') )
+! + PRE * J(r) * int( dr' r'^2 H2(r') * op(V(r')) * SLL(r') )
+!
+! ************************************************************************
+! Potential matrix : VLL(LMSIZE*NVEC,LMSIZE*NVEC)
+! LMSIZE = LMMAX (number of LM components) x Number of spin components
+! LMSIZE2 = NVEC* LMSIZE
+! NVEC is 2 for a spinor and 1 in case of a non-rel. calculation
+!
+! ************************************************************************
+! Green function prefactor PRE=GMATPREFACTOR (scalar value)
+! tipically \kappa for non-relativistic and M_0 \kappa for SRA
+!
+! ************************************************************************
-DOUBLE PRECISION, PARAMETER :: cvlight=274.0720442D0
-DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
-DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
+! ************************************************************************
+! The discretization of the Lippmann-Schwinger equation results in a matrix
+! equation which is solved in this routine. Further information is given
+! in section 5.2.3, page 90 of Bauer, PhD
+!
+! Source terms :
+! right solution: J, H (nvec*lmsize,lmsize) or (lmsize,nvec*lmsize)
+! left solution: J2,H2 (lmsize,nvec*lmsize) or (nvec*lmsize,lmsize)
+!
+! Example:
+! The source term J is for LMSIZE=3 and NVEC=2 given by:
+! J = / jlk(jlk_index(1)) \
+! | 0 jlk(jlk_index(2)) |
+! | 0 0 jlk(jlk_index(3)) |
+! | jlk(jlk_index(4)) |
+! | 0 jlk(jlk_index(5)) |
+! \ 0 0 jlk(jlk_index(6)) /
+!
+! first 3 rows are for the large and the last 3 rows for the small component
+! ************************************************************************
+! Operator op() can be chosen to be a unity or a transpose operation
+! The unity operation is used to calculate the right solution
+! The transpose operation is used to calculate the left solution
+! ************************************************************************
+! RMESH - radial mesh
+! RPANBOUND - panel bounds RPANBOUND(0) left panel border of panel 1
+! RPANBOUND(1) right panel border of panel 1
+! NCHEB - highes chebyshev polynomial
+! number of points per panel = NCHEB + 1
+! NPAN - number of panels
+! LMSIZE - number of colums for the source matrix J etc...
+! LMSIZE2 - number of rows for the source matrix J etc...
+! NRMAX - total number of radial points (NPAN*(NCHEB+1))
+! NVEC - number of LMSIZE*LMSIZE blocks in J (LMSIZE2=NVEC*LMSIZE)
+! ************************************************************************
+implicit none
+ integer :: ncheb ! number of chebyshev nodes
+ integer :: npan ! number of panels
+ integer :: lmsize ! lm-components * nspin
+ integer :: lmsize2 ! lmsize * nvec
+ integer :: nvec ! spinor integer
+ ! nvec=1 non-rel, nvec=2 for sra and dirac
+ integer :: nrmax ! total number of rad. mesh points
+ integer :: LBESSEL, use_sratrick1 ! dimensions etc., needed only for host code interface
+ integer :: iter_beta, niter_beta
-DOUBLE COMPLEX, allocatable :: tmatll(:,:)
-INTEGER :: ir,use_sratrick,nvec,lm1,irmdnew
-DOUBLE COMPLEX gmatprefactor
-DOUBLE PRECISION, allocatable :: vins(:,:,:)
-DOUBLE COMPLEX, allocatable :: vnspll0(:,:,:),vnspll1(:,:,:,:), vnspll(:,:,:,:)
-DOUBLE COMPLEX, allocatable :: hlk(:,:,:),jlk(:,:,:), hlk2(:,:,:),jlk2(:,:,:)
-DOUBLE COMPLEX, allocatable :: rll(:,:,:,:)
-!DOUBLE COMPLEX, allocatable :: rllleft(:,:,:,:),sllleft(:,:,:,:) ! neded for D_ij calculation
-DOUBLE COMPLEX, allocatable :: tmatsph(:,:)! TMAT_OUT(:,:), tmat_out necessary for parallel ie loop
-DOUBLE COMPLEX, allocatable :: dtmatll(:,:),tmat0(:,:) ! LLY
-DOUBLE COMPLEX, allocatable :: alphall(:,:),dalphall(:,:),alpha0(:,:),aux(:,:) ! LLY
-!DOUBLE COMPLEX, allocatable :: alphasph(:)!, DTMAT_OUT(:,:,:), ! LLY
-INTEGER, allocatable :: jlk_index(:)
-! LLoyd:
-!INTEGER :: ideriv,signde ! LLY
-!DOUBLE COMPLEX :: tralpha ! LLY
-DOUBLE COMPLEX, allocatable :: ipiv(:) ! LLY
-! .. OMP ..
-INTEGER :: nth,ith ! total number of threads and thread id
-
-lmmaxd = (lmax+1)**2
-lmmaxso=2*lmmaxd
-nrmaxd=irmd_new
+ double complex,parameter:: ci= (0.0d0,1.0d0), &! complex i
+ cone=(1.0d0,0.0d0),&! 1
+ czero=(0.0d0,0.0d0) ! 0
+ ! running indices
+ integer lm1,lm2
+ integer icheb,ipan,mn
+ integer :: info, ipiv(lmsize)
-allocate(tmatll(lmmaxso,lmmaxso))
-allocate(dtmatll(lmmaxso,lmmaxso))
-allocate(tmat0(lmmaxso,lmmaxso))
-allocate(alphall(lmmaxso,lmmaxso))
-allocate(dalphall(lmmaxso,lmmaxso))
-allocate(alpha0(lmmaxso,lmmaxso))
-allocate(aux(lmmaxso,lmmaxso))
-allocate(jlk_index(2*lmmaxso))
-allocate(ipiv(lmmaxso))
-! .. OMP ..
-! determine if omp parallelisation is used (compiled with -openmp flag and
-! OMP_NUM_THREADS>1)
-!$noomp parallel shared(nth,ith)
-!$noomp single
-nth = 1
-ith = 0
-!nth = omp_get_num_threads()
-!$noomp end single
-!$noomp end parallel
-! write(*,*) 'nth =',nth
+ ! source terms
+ double complex :: gmatprefactor ! prefactor of green function
+ ! non-rel: = kappa = sqrt e
+ DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
+ JLK(LBESSEL,NRMAX), &
+ HLK2(LBESSEL,NRMAX), &
+ JLK2(LBESSEL,NRMAX)
+ INTEGER JLK_INDEX(2*LMSIZE)
-irmdnew= npan_tot*(ncheb+1)
-allocate(vins(irmdnew,lmpotd,nspin))
-vins=0D0
-DO lm1=1,lmpotd
- DO ir=1,irmdnew
- vins(ir,lm1,1)=vinsnew(ir,lm1,ipot)
- vins(ir,lm1,nspin)=vinsnew(ir,lm1,ipot+nspin-1)
- END DO
-END DO
-!c set up the non-spherical ll' matrix for potential VLL'
- IF (NSRA.EQ.2) THEN
-USE_SRATRICK=1
-ELSEIF (NSRA.EQ.1) THEN
-USE_SRATRICK=0
-ENDIF
-allocate(vnspll0(lmmaxso,lmmaxso,irmdnew))
-allocate(vnspll1(lmmaxso,lmmaxso,irmdnew,0:nth-1))
-vnspll0=czero
-CALL vllmat(1,irmdnew,lmmaxd,lmmaxso,vnspll0,vins, &
- cleb,icleb,iend,nspin,zat,rnew,use_sratrick)
+ double complex :: sll(lmsize2,lmsize,nrmax), & ! irr. volterra sol.
+ vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7, bauer, phd
-! initial allocate
-IF (nsra == 2) THEN
- allocate(vnspll(2*lmmaxso,2*lmmaxso,irmdnew,0:nth-1))
-ELSE
- allocate(vnspll(lmmaxso,lmmaxso,irmdnew,0:nth-1))
-END IF
+ double complex,allocatable :: &
+ work(:,:), &
+ cllp(:,:,:),dllp(:,:,:), &
+ cllptemp(:,:),dllptemp(:,:), &
+ mihvy(:,:,:),mihvz(:,:,:), &
+ mijvy(:,:,:),mijvz(:,:,:)
+ double complex,allocatable :: yif(:,:,:,:), zif(:,:,:,:)
+ double complex,allocatable :: betainv(:,:),betainv_save(:,:)
+
+ complex*32, allocatable :: qcllp(:, :, :), qdllp(:, :, :)
+ complex*32, allocatable :: qmihvy(:, :), qmihvz(:, :), qmijvy(:, :), qmijvz(:, :)
+ complex*32, allocatable :: qyif(:, :, :)
+ complex*32, allocatable :: qcllptemp(:, :), qdllptemp(:, :)
+ complex*32, allocatable :: qsll(:, :)
+ complex*32, allocatable :: qcone, qczero
+ complex*32, allocatable :: qbetainv(:, :), qbetainv_save(:, :)
-allocate(hlk(1:4*(lmax+1),irmdnew,0:nth-1))
-allocate(jlk(1:4*(lmax+1),irmdnew,0:nth-1))
-allocate(hlk2(1:4*(lmax+1),irmdnew,0:nth-1))
-allocate(jlk2(1:4*(lmax+1),irmdnew,0:nth-1))
-allocate(tmatsph(2*(lmax+1),0:nth-1))
-allocate(rll(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-!allocate(rllleft(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-!allocate(sllleft(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-!allocate(tmat_out(lmmaxso,lmmaxso))
+ ! chebyshev arrays
+ double precision c1(0:ncheb,0:ncheb),rpanbound(0:npan)
+ double precision cslc1(0:ncheb,0:ncheb), & ! Integration matrix from left ( C*S_L*C^-1 in eq. 5.53)
+ csrc1(0:ncheb,0:ncheb), & ! Same from right ( C*S_R*C^-1 in eq. 5.54)
+ tau(0:ncheb,0:npan), & ! Radial mesh point
+ slc1sum(0:ncheb),rmesh(nrmax),drpan2
-! energy loop
-!WRITE(6,*) 'atom: ',i1,' NSRA:',nsra
-
-!!$noomp parallel do default(none)
-!!$noomp& private(eryd,ie,i1,ir,irec,nvec,lm1,lm2,gmatprefactor)
-!!$noomp& private(jlk_index,tmatll,ith)
-!!$noomp& shared(nspin,nsra,lmax,iend,ipot,ielast,npan_tot,ncheb)
-!!$noomp& shared(zat,socscale,ez,rmesh,cleb,rnew,nth)
-!!$noomp& shared(rpan_intervall,vinsnew,ipan_intervall)
-!!$noomp& shared(use_sratrick,irmdnew,theta,phi,vins,vnspll0)
-!!$noomp& shared(vnspll1,vnspll,hlk,jlk,hlk2,jlk2,rll,tmat_out)
-!!$noomp& shared(tmatsph)
-!DO ie=1,ielast
-! get current thread
-! IF (nth>=1) THEN
-! ith = omp_get_thread_num()
-! ELSE
- ith = 0
-! END IF
- eryd = ez(ie)
-!!$noomp critical
-! WRITE(6,*) 'energy:',ie,'',eryd
-!write(*,*) 'nested omp?',omp_get_nested()
-!!$noomp end critical
-
-! contruct the spin-orbit coupling hamiltonian and add to potential
- CALL spinorbit_ham(lmax,lmmaxd,vins,rnew, &
- eryd,zat,cvlight,socscale,nspin,lmpotd, &
- theta,phi,ipan_intervall,rpan_intervall, npan_tot,ncheb,irmdnew,nrmaxd, &
- vnspll0(:,:,:),vnspll1(:,:,:,ith),'1',soc)
-!c extend matrix for the SRA treatment
- vnspll(:,:,:,ith)=czero
- IF (nsra == 2) THEN
- IF (use_sratrick == 0) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
- ELSE IF (use_sratrick == 1) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
- END IF
- ELSE
- vnspll(:,:,:,ith)=vnspll1(:,:,:,ith)
- END IF
-
-!c calculate the source terms in the Lippmann-Schwinger equation
-!c these are spherical hankel and bessel functions
- hlk(:,:,ith)=czero
- jlk(:,:,ith)=czero
- hlk2(:,:,ith)=czero
- jlk2(:,:,ith)=czero
- gmatprefactor=czero
- CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
- lmmaxso,1,jlk_index,hlk(:,:,ith), &
- jlk(:,:,ith),hlk2(:,:,ith),jlk2(:,:,ith), gmatprefactor)
-!c using spherical potential as reference
- IF (use_sratrick == 1) THEN
- CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
- rnew,vins,ncheb,npan_tot,rpan_intervall, &
- jlk_index,hlk(:,:,ith),jlk(:,:,ith),hlk2(:,:,ith), &
- jlk2(:,:,ith),gmatprefactor,tmatsph(:,ith), use_sratrick)
- END IF
-
-!c calculate the tmat and wavefunctions
- rll(:,:,:,ith)=czero
-
-!c right solutions
- tmatll=czero
- CALL rll_only(rpan_intervall,rnew,vnspll(:,:,:,ith), &
- rll(:,:,:,ith),tmatll(:,:),ncheb, &
- npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1),irmdnew, &
- nsra,jlk_index,hlk(:,:,ith),jlk(:,:,ith), &
- hlk2(:,:,ith),jlk2(:,:,ith),gmatprefactor, '1','1',use_sratrick)
-! & ,ith) ! test fivos
-! IF (nsra == 2) THEN
-! RLL(LMMAXSO+1:NVEC*LMMAXSO,:,:,ith)=
-! + RLL(LMMAXSO+1:NVEC*LMMAXSO,:,:,ith)/C
-! END IF
-!if(t_dtmatjij_at%calculate) then
+ double precision dllpmax,dllpval
+ logical :: enable_quad_prec, new_sll
+ integer :: use_sratrick
+ external zgetrf,zgetrs,zgemm,zgetri
+ intrinsic abs,atan,cos,dimag,exp,max,min,sin,sqrt
-
- !for Jij-tensor calculation: allocate array to hold additional t-matrices
-! call init_t_dtmatJij_at(t_dtmatJij_at)
-!
-!
-!! lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll
-!! lllllllllll calculate the left-hand side solution lllllllllllllllllllllllllllllllllllll
-!! contruct the spin-orbit coupling hamiltonian and add to potential
-! call spinorbit_ham(lmax,lmmaxd,vins,rnew, &
-! eryd,zat,cvlight,socscale,nsra,nspin,lmpotd, &
-! theta,phi,ipan_intervall,rpan_intervall, &
-! npan_tot,ncheb,irmdnew,nrmaxd, &
-! vnspll0(:,:,:),vnspll1(:,:,:,ith), &
-! 'transpose',soc)
-!
-!! extend matrix for the sra treatment
-! vnspll(:,:,:,ith)=czero
-! if (nsra.eq.2) then
-! if (use_sratrick.eq.0) then
-! call vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
-! lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'ref=0')
-! elseif (use_sratrick.eq.1) then
-! call vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
-! lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'ref=vsph')
-! endif
-! else
-! vnspll(:,:,:,ith)=vnspll1(:,:,:,ith)
-! endif
-!
-!! calculate the source terms in the lippmann-schwinger equation
-!! these are spherical hankel and bessel functions
-! hlk(:,:,ith)=czero
-! jlk(:,:,ith)=czero
-! hlk2(:,:,ith)=czero
-! jlk2(:,:,ith)=czero
-! gmatprefactor=czero
-! jlk_index = 0
-! call rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
-! lmmaxso,1,jlk_index,hlk(:,:,ith), &
-! jlk(:,:,ith),hlk2(:,:,ith),jlk2(:,:,ith), &
-! gmatprefactor)
-!
-!! using spherical potential as reference
-!! notice that exchange the order of left and right hankel/bessel functions
-! if (use_sratrick.eq.1) then
-! tmatsph(:,ith)=czero
-! call calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
-! lmpotd,lmmaxso,rnew,vins,ncheb,npan_tot,rpan_intervall, &
-! jlk_index,hlk2(:,:,ith),jlk2(:,:,ith),hlk(:,:,ith), &
-! jlk(:,:,ith),gmatprefactor,tmatsph(:,ith), &
-! use_sratrick)
-! endif
-!
-!! calculate the tmat and wavefunctions
-! rllleft(:,:,:,ith)=czero
-! sllleft(:,:,:,ith)=czero
-!
-!! left solutions
-!! notice that exchange the order of left and right hankel/bessel functions
-! tmat0=czero
-! alpha0=czero ! lly
-! call rllsll(rpan_intervall,rnew,vnspll(:,:,:,ith), &
-! rllleft(:,:,:,ith),sllleft(:,:,:,ith),tmat0,ncheb, &
-! npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1),irmdnew, &
-! nrmaxd,nsra,jlk_index,hlk2(:,:,ith),jlk2(:,:,ith), &
-! hlk(:,:,ith),jlk(:,:,ith),gmatprefactor, &
-! '1','1','0',use_sratrick)
-! if (nsra.eq.2) then
-! rllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)= &
-! rllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)/cvlight
-! sllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)= &
-! sllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)/cvlight
-! endif
-!! lllllllllll calculate the left-hand side solution lllllllllllllllllllllllllllllllllllll
-!! lllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllllll
+! ***********************************************************************
+! SRA trick
+! ***********************************************************************
+! on page 68 of Bauer, PhD, a method is described how to speed up the
+! calculations in case of the SRA. A similar approach is implemented
+! here by using Eq. 4.132 and substituting DV from 4.133, and discretising
+! the radial mesh of the Lippmann-Schwinger eq. according to 5.68.
+! The Lippmann-Schwinger equation leads to a matrix inversion
+! problem. The matrix M which needs to be inverted has a special form
+! if the SRA approximation is used:
+!
+! matrix A ( C 0) (same as in eq. 5.68)
+! ( B 1)
+! (C, B are matricies here)
!
-! call calc_dtmatjij(lmaxd,lmmaxd,lmmaxso,lmpotd,ntotd,nrmaxd, &
-! nsra,irmdnew,nspin,vins,rllleft(:,:,:,ith),rll(:,:,:,ith), &
-! rpan_intervall, &
-! ipan_intervall,npan_tot,ncheb,cleb,icleb,iend,ncleb,rnew, &
-! theta,phi,t_dtmatjij_at%dtmat_xyz(:,:,:,ie_num))
+! inverse of A is (C^-1 0 )
+! (-B C^-1 1 )
+! Thus, it is sufficient to only inverse the matrix C which saves computational
+! time. This is refered to as the SRA trick.
+! ***********************************************************************
+! in future implementation equation 4.134 is supposed to be
+! implemented which should lead to an additional speed-up.
+! ***********************************************************************
-! end if!t_dtmatjij_at%calculate
-
-
-! add spherical contribution of tmatrix
- IF (use_sratrick == 1) THEN
- DO lm1=1,lmmaxso
- tmatll(lm1,lm1)=tmatll(lm1,lm1)+tmatsph(jlk_index(lm1),ith)
- END DO
- END IF
- TmatN(:,:) = tmatll(:,:)
-!END DO ! IE loop
-!!$noomp end parallel do
-
-! serial write out after parallel calculation of tmat
-!DO ie=1,ielast
-! irec = ie + ielast*(i1-1)
-! WRITE(69,REC=irec) tmat_out(:,:,ie)
-! write(696969,*) TMAT_out(:,:,ie)
-!END DO
+ niter_beta = 3
+ if(.not.enable_quad_prec) niter_beta = 2
-deallocate(vins)
-deallocate(vnspll0)
-deallocate(vnspll1)
-deallocate(vnspll)
-deallocate(hlk)
-deallocate(jlk)
-deallocate(hlk2)
-deallocate(jlk2)
-deallocate(tmatsph)
-deallocate(rll)
+if ( lmsize==1 ) then
+ use_sratrick=0
+else
+ use_sratrick=use_sratrick1
+end if
-END SUBROUTINE tmat_newsolver
+if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
+if(.not.allocated(betainv)) allocate( betainv(lmsize,lmsize) )
+if(.not.allocated(betainv_save)) allocate( betainv_save(lmsize,lmsize) )
+if(.not.allocated(cllp)) allocate( cllp(lmsize,lmsize,0:npan) )
+if(.not.allocated(dllp)) allocate( dllp(lmsize,lmsize,0:npan) )
+if(.not.allocated(cllptemp)) allocate( cllptemp(lmsize,lmsize) )
+if(.not.allocated(dllptemp)) allocate( dllptemp(lmsize,lmsize) )
+if(.not.allocated(mihvy)) allocate( mihvy(lmsize,lmsize,npan) )
+if(.not.allocated(mihvz)) allocate( mihvz(lmsize,lmsize,npan) )
+if(.not.allocated(mijvy)) allocate( mijvy(lmsize,lmsize,npan) )
+if(.not.allocated(mijvz)) allocate( mijvz(lmsize,lmsize,npan) )
+if(.not.allocated(betainv)) allocate (betainv(lmsize,lmsize))
+if(.not.allocated(betainv_save)) allocate (betainv_save(lmsize,lmsize))
-! ************************************************************************
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-18 Time: 14:28:39
+if(.not.allocated(yif)) allocate( yif(lmsize2,lmsize,0:ncheb,npan) )
+if(.not.allocated(zif)) allocate( zif(lmsize2,lmsize,0:ncheb,npan) )
-SUBROUTINE vllmat(irmin,irc,lmmax,lmmaxso,vnspll0,vins, &
- cleb,icleb,iend,nspin,z,rnew,use_sratrick)
-! ************************************************************************
-! .. Parameters ..
-IMPLICIT NONE
+do ipan = 1,npan
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ tau(icheb,ipan) = rmesh(mn)
+ end do
+end do
-INTEGER, INTENT(IN) :: irmin
-!INTEGER, INTENT(IN) :: nrmaxd
-INTEGER, INTENT(IN) :: irc
-INTEGER, INTENT(IN) :: lmmax
-INTEGER, INTENT(IN) :: lmmaxso
-DOUBLE COMPLEX, INTENT(OUT) :: vnspll0(:,:,irmin:)
-DOUBLE PRECISION, INTENT(IN OUT) :: vins(irmin:,:,:)
-DOUBLE PRECISION, INTENT(IN) :: cleb(:)
-INTEGER, INTENT(IN) :: icleb(:,:)
-INTEGER, INTENT(IN) :: iend
-INTEGER, INTENT(IN) :: nspin
-DOUBLE PRECISION, INTENT(IN) :: z
-DOUBLE PRECISION, INTENT(IN) :: rnew(irmin:)
-INTEGER, INTENT(IN OUT) :: use_sratrick
-!INCLUDE 'inc.p'
-!INTEGER :: lmpotd
-!DOUBLE PRECISION, INTENT, PARAMETER :: lmpotd= (lpotd+1)**2
-! ..
-! .. Scalar Arguments ..
+call chebint(cslc1,csrc1,slc1sum,c1,ncheb)
-INTEGER :: isp
-! ..
-! .. Array Arguments ..
-DOUBLE PRECISION, allocatable :: vnspll(:,:,:,:)
+ do ipan = 1, npan
-! ..
-! .. Local Scalars ..
-INTEGER :: i,ir,j,lm1,lm2,lm3
-! ..
+ drpan2 = (rpanbound(ipan)-rpanbound(ipan-1))/2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
+ call sll_local_solutions(vll,tau(0,ipan),drpan2,csrc1, slc1sum, &
+ mihvy(1,1,ipan),mihvz(1,1,ipan),mijvy(1,1,ipan),mijvz(1,1,ipan), &
+ yif(1,1,0,ipan),zif(1,1,0,ipan),ncheb,ipan,lmsize,lmsize2,nrmax,nvec, &
+ jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor,lbessel,use_sratrick1)
-allocate(vnspll(lmmax,lmmax,irmin:irc,2))
+ end do ! ipan
-DO isp=1,nspin
- DO lm1 = 1,lmmax
- DO lm2 = 1,lm1
- DO ir = irmin,irc
- vnspll(lm1,lm2,ir,isp) = 0.0D0
- END DO
- END DO
- END DO
-
- DO j = 1,iend
- lm1 = icleb(j,1)
- lm2 = icleb(j,2)
- lm3 = icleb(j,3)
- DO i = irmin,irc
- vnspll(lm1,lm2,i,isp) = vnspll(lm1,lm2,i,isp) + cleb(j)*vins(i,lm3,isp)
- END DO
- END DO
-
-!---> use symmetry of the gaunt coef.
-
- DO lm1 = 1,lmmax
- DO lm2 = 1,lm1 - 1
- DO i = irmin,irc
- vnspll(lm2,lm1,i,isp) = vnspll(lm1,lm2,i,isp)
- END DO
- END DO
- END DO
-
- IF (use_sratrick == 0) THEN
- DO lm1=1,lmmax
- DO i=irmin,irc
- vnspll(lm1,lm1,i,isp)=vnspll(lm1,lm1,i,isp)+ &
- vins(i,1,isp)-2D0*z/rnew(i)
- END DO
- END DO
- END IF
-
-END DO !NSPIN
+! ***********************************************************************
+! calculate C(M), D(M)
+! (starting condition: C(NPAN) = 0 and D(NPAN) = 1)
+! ***********************************************************************
-! set vnspll as twice as large
+dllp(:,:,npan) = czero
+cllp(:,:,npan) = czero
+do lm1 = 1,lmsize
+ dllp(lm1,lm1,npan) = cone
+end do
-vnspll0(1:lmmax,1:lmmax,irmin:irc)= vnspll(1:lmmax,1:lmmax,irmin:irc,1)
+do ipan = npan,1,-1
-vnspll0(lmmax+1:lmmaxso,lmmax+1:lmmaxso,irmin:irc)= &
- vnspll(1:lmmax,1:lmmax,irmin:irc,nspin)
-END SUBROUTINE vllmat
+ cllp(:,:,ipan-1) = cllp(:,:,ipan)
+ dllp(:,:,ipan-1) = dllp(:,:,ipan)
+ call zgemm('n','n',lmsize,lmsize,lmsize, cone,mihvz(1,1,ipan), &
+ lmsize,cllp(1,1,ipan),lmsize,cone,cllp(1,1,ipan-1),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize, cone,mihvy(1,1,ipan), &
+ lmsize,dllp(1,1,ipan),lmsize,cone,cllp(1,1,ipan-1),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mijvz(1,1,ipan), &
+ lmsize,cllp(1,1,ipan),lmsize,cone,dllp(1,1,ipan-1),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mijvy(1,1,ipan), &
+ lmsize,dllp(1,1,ipan),lmsize,cone,dllp(1,1,ipan-1),lmsize)
+end do
-SUBROUTINE spinorbit_ham(lmax,lmmaxd,vins,rnew,e,z,c,socscale, &
- nspin,lmpotd,theta,phi, &
- ipan_intervall,rpan_intervall, &
- npan_tot,ncheb,irmdnew,nrmaxd,vnspll,vnspll1, &
- mode,soc)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-18 Time: 14:28:35
+! ***********************************************************************
+! determine the irregular solution sll by using 5.14
+! ***********************************************************************
-IMPLICIT NONE
+if(.not.new_sll) then
+do ipan = 1,npan
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ call zgemm('n','n',lmsize2,lmsize,lmsize,cone,zif(1,1,icheb,ipan), &
+ lmsize2,cllp(1,1,ipan),lmsize,czero,sll(1,1,mn),lmsize2)
+ call zgemm('n','n',lmsize2,lmsize,lmsize,cone,yif(1,1,icheb,ipan), &
+ lmsize2,dllp(1,1,ipan),lmsize,cone,sll(1,1,mn),lmsize2)
+ end do
+end do
+else
-INTEGER, INTENT(IN) :: lmax
-INTEGER, INTENT(IN) :: lmmaxd
-DOUBLE PRECISION, INTENT(IN) :: vins(irmdnew,lmpotd,nspin)
-DOUBLE PRECISION, INTENT(IN) :: rnew(nrmaxd)
-DOUBLE COMPLEX, INTENT(IN OUT) :: e
-DOUBLE PRECISION, INTENT(IN) :: z
-DOUBLE PRECISION, INTENT(IN) :: c
-DOUBLE PRECISION, INTENT(IN) :: socscale
-!INTEGER, INTENT(IN) :: nsra
-INTEGER, INTENT(IN) :: nspin
-INTEGER, INTENT(IN) :: lmpotd
-DOUBLE PRECISION, INTENT(IN) :: theta
-DOUBLE PRECISION, INTENT(IN) :: phi
-INTEGER, INTENT(IN) :: ipan_intervall(0:)
-DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
-INTEGER, INTENT(IN) :: npan_tot
-INTEGER, INTENT(IN) :: ncheb
-INTEGER, INTENT(IN) :: irmdnew
-INTEGER, INTENT(IN OUT) :: nrmaxd
-DOUBLE COMPLEX, INTENT(IN) :: vnspll(:,:,:)
-DOUBLE COMPLEX, INTENT(OUT) :: vnspll1(:,:,:)
-CHARACTER(LEN=*), INTENT(IN) :: mode
-LOGICAL, INTENT(IN) :: soc !switches SOC on and off
+if(.not.allocated(cllptemp)) allocate( cllptemp(lmsize,lmsize) )
+if(.not.allocated(dllptemp)) allocate( dllptemp(lmsize,lmsize) )
+
+ betainv = dllp(:, :, 0)
+
+ call zgetrf(lmsize, lmsize, betainv, lmsize, ipiv, info) ! invert beta
+ call zgetri(lmsize, betainv, lmsize, ipiv, work, lmsize*lmsize, info)
+
+if(enable_quad_prec) then
+if(.not.allocated(qcone)) allocate (qcone)
+if(.not.allocated(qczero)) allocate (qczero)
+if(.not.allocated(qmihvy)) allocate (qmihvy(lmsize,lmsize))
+if(.not.allocated(qmihvz)) allocate (qmihvz(lmsize,lmsize))
+if(.not.allocated(qmijvy)) allocate (qmijvy(lmsize,lmsize))
+if(.not.allocated(qmijvz)) allocate (qmijvz(lmsize,lmsize))
+if(.not.allocated(qyif)) allocate (qyif(lmsize2,lmsize,0:ncheb))
+if(.not.allocated(qbetainv)) allocate (qbetainv(lmsize,lmsize))
+if(.not.allocated(qbetainv_save)) allocate (qbetainv_save(lmsize,lmsize))
+if(.not.allocated(qsll)) allocate (qsll(lmsize2,lmsize))
+if(.not.allocated(qcllp)) allocate (qcllp(lmsize,lmsize,0:npan))
+if(.not.allocated(qdllp)) allocate (qdllp(lmsize,lmsize,0:npan))
+if(.not.allocated(qcllptemp)) allocate (qcllptemp(lmsize,lmsize))
+if(.not.allocated(qdllptemp)) allocate (qdllptemp(lmsize,lmsize))
+ qcone = (1.q0,0.0q0)
+ qczero = (0.q0,0.0q0)
+ qbetainv = betainv
+end if
+ do iter_beta = 1, niter_beta
+ if(.not.enable_quad_prec) then
+ dllp(:, :, npan) = betainv
+ cllp(:, :, npan) = czero
+ do lm2 = 1, lmsize
+ dllp(lm2, lm2, npan) = betainv(lm2,lm2) - cone
+ end do
-DOUBLE PRECISION :: vr(irmdnew),dvdr(irmdnew)
-DOUBLE PRECISION :: rmass(irmdnew),hsofac(irmdnew)
-DOUBLE PRECISION :: rnucl,atn,widthfac
-INTEGER :: ir,ip,lm1,lm2,ispin,irmin,irmax,ncoll
-DOUBLE COMPLEX lsmh(2*lmmaxd,2*lmmaxd),temp
-DOUBLE PRECISION :: clambdacinv(0:ncheb,0:ncheb)
-!DOUBLE PRECISION :: matvec_dmdm
-LOGICAL :: test,opt
-EXTERNAL test,opt
+ do ipan = npan, 1, -1
-vnspll1=(0D0,0D0)
-vr=0D0
-DO ispin=1,nspin
- DO ir=1,ipan_intervall(npan_tot)
- vr(ir)=vr(ir)+vins(ir,1,ispin)/nspin
- END DO
-END DO
-! derivative of potential
-dvdr=0D0
-CALL getclambdacinv(ncheb,clambdacinv)
-DO ip=1,npan_tot
- irmin=ipan_intervall(ip-1)+1
- irmax=ipan_intervall(ip)
- widthfac= 2D0/(rpan_intervall(ip)-rpan_intervall(ip-1))
- CALL dgemv('N',ncheb+1,ncheb+1,1D0,clambdacinv,ncheb+1, &
- vr(irmin:irmax),1,0D0,dvdr(irmin:irmax),1)
- dvdr(irmin:irmax)= dvdr(irmin:irmax)*widthfac
-END DO
-! core potential
-IF (z > 24D0) THEN
- atn=-16.1532921+2.70335346*z
-ELSE
- atn=0.03467714+2.04820786*z
-END IF
-rnucl=1.2D0/0.529177D0*atn**(1./3D0)*1.d-5
+ cllp(:, :, ipan-1) = cllp(:, :, ipan) + mihvy(:, :, ipan)
+ dllp(:, :, ipan-1) = dllp(:, :, ipan) - mijvy(:, :, ipan)
-DO ir=1,ipan_intervall(npan_tot)
- IF (rnew(ir) <= rnucl) THEN
-! DVDR(IR)=DVDR(IR)+2d0*Z*RNEW(IR)/RNUCL**3d0
- ELSE
-! DVDR(IR)=DVDR(IR)+2d0*Z/RNEW(IR)**2d0
- END IF
- dvdr(ir)=dvdr(ir)+2D0*z/rnew(ir)**2D0
-END DO
-! contruct LS matrix
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, cone, mihvz(1,1,ipan), lmsize, cllp(1,1,ipan), lmsize, cone, cllp(1,1,ipan-1), lmsize)
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, cone, mihvy(1,1,ipan), lmsize, dllp(1,1,ipan), lmsize, cone, cllp(1,1,ipan-1), lmsize)
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, -cone, mijvz(1,1,ipan), lmsize, cllp(1,1,ipan), lmsize, cone, dllp(1,1,ipan-1), lmsize)
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, -cone, mijvy(1,1,ipan), lmsize, dllp(1,1,ipan), lmsize, cone, dllp(1,1,ipan-1), lmsize)
-CALL spin_orbit_compl(lmax,lmmaxd,lsmh)
+ end do
-! roate LS matrix
-ncoll=1
-IF (ncoll == 1) THEN
- CALL rotatematrix(lsmh,theta,phi,lmmaxd,1)
-END IF
+ betainv_save = betainv
-IF (mode == 'transpose') THEN
- DO lm1=1,2*lmmaxd
- DO lm2=1,lm1-1
- temp=lsmh(lm2,lm1)
- lsmh(lm2,lm1)=lsmh(lm1,lm2)
- lsmh(lm1,lm2)=temp
- END DO
- END DO
-ELSE IF (mode == '1') THEN
-END IF
-! contruct prefactor of spin-orbit hamiltonian
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, -cone, betainv_save, lmsize, dllp(1,1,0), lmsize, cone, betainv, lmsize)
-hsofac=0D0
-DO ir=1,irmdnew
- rmass(ir)=0.5D0-0.5D0/c**2*((vr(ir)-REAL(e))-2D0*z/rnew(ir))
- IF (soc .eqv. .false. .OR. z < 1D-6) THEN
- hsofac(ir)=0D0
- ELSE
- hsofac(ir)=socscale/(2D0*rmass(ir)**2*c**2*rnew(ir))*dvdr(ir)
- END IF
-
-! add to potential
-
- DO lm1=1,2*lmmaxd
- DO lm2=1,2*lmmaxd
- vnspll1(lm1,lm2,ir)=vnspll(lm1,lm2,ir)+hsofac(ir)*lsmh(lm1,lm2)
- END DO
- END DO
-END DO
-END SUBROUTINE spinorbit_ham
+! dllpmax = 0.d0
+! do lm1 = 1,lmsize
+! do lm2 = 1,lmsize
+! dllpval = dllp(lm1,lm2,0)
+! if(lm1.ne.lm2.and.abs(dllpval).gt.dllpmax) dllpmax = abs(dllpval)
+! if(lm1.eq.lm2.and.abs(dllpval-cone).gt.dllpmax) dllpmax = abs(dllpval-cone)
+! end do
+! end do
+ else
-subroutine vllmatsra(vll0,vll,rmesh,lmsize,nrmax,nrmaxd,eryd,cvlight,lmax,lval_in,cmode)
-!************************************************************************************
-! The perubation matrix for the SRA-equations are set up
-!************************************************************************************
-implicit none
-!interface
- DOUBLE COMPLEX VLL(2*lmsize,2*lmsize,nrmax)
- DOUBLE COMPLEX VLL0(lmsize,lmsize,nrmax)
- double precision :: rmesh(nrmaxd)
- double complex :: eryd
- double precision :: cvlight
- integer :: lmax,lval_in
- integer :: lmsize,nrmax,nrmaxd
- character(len=*) :: cmode
-!local
- integer :: ilm,lval,mval,ival,ir
- integer :: loflm(lmsize)
- double complex :: Mass,Mass0
- double complex,parameter :: cone=(1.0D0,0.0D0)
- double complex,parameter :: czero=(0.0D0,0.0D0)
+ qdllp(:, :, npan) = qbetainv
+ qcllp(:, :, npan) = qczero
+ do lm2 = 1, lmsize
+ qdllp(lm2, lm2, npan) = qbetainv(lm2,lm2) - qcone
+ end do
-!************************************************************************************
-! determine the bounds of the matricies to get the lm-expansion and the max. number
-! of radial points
-!************************************************************************************
+ do ipan = npan, 1, -1
+ qmihvz(:, :) = mihvz(:, :, ipan)
+ qmihvy(:, :) = mihvy(:, :, ipan)
+ qmijvz(:, :) = mijvz(:, :, ipan)
+ qmijvy(:, :) = mijvy(:, :, ipan)
+ qcllp(:, :, ipan-1) = qcllp(:, :, ipan) + qmihvy(:, :)
+ qdllp(:, :, ipan-1) = qdllp(:, :, ipan) - qmijvy(:, :)
-!************************************************************************************
-! calculate the index array to determine the L value of an LM index
-! in case of spin-orbit coupling 2*(LMAX+1)**2 are used instead of (LMAX+1)**2
-! the second half refers to the second spin and has the the same L value
-!************************************************************************************
-ilm=0
+ call cqgemm(lmsize,lmsize,lmsize,qcone,qmihvz,lmsize,qcllp(1,1,ipan),lmsize,qcone,qcllp(1,1,ipan-1),lmsize)
+ call cqgemm(lmsize,lmsize,lmsize,qcone,qmihvy,lmsize,qdllp(1,1,ipan),lmsize,qcone,qcllp(1,1,ipan-1),lmsize)
+ call cqgemm(lmsize,lmsize,lmsize,-qcone,qmijvz,lmsize,qcllp(1,1,ipan),lmsize,qcone,qdllp(1,1,ipan-1),lmsize)
+ call cqgemm(lmsize,lmsize,lmsize,-qcone,qmijvy,lmsize,qdllp(1,1,ipan),lmsize,qcone,qdllp(1,1,ipan-1),lmsize)
-if (lmsize==1) then
- loflm(1)=lval_in
-elseif ((lmax+1)**2 == lmsize) then
- do lval=0,lmax
- do mval = -lval,lval
- ilm=ilm+1
- loflm(ilm)=lval
end do
- end do
-elseif (2* (lmax+1)**2 ==lmsize ) then
- do ival=1,2
- do lval=0,lmax
- do mval = -lval,lval
- ilm=ilm+1
- loflm(ilm)=lval
+
+ qbetainv_save = qbetainv
+
+ call cqgemm(lmsize, lmsize, lmsize, -qcone, qbetainv_save, lmsize, qdllp(1,1,0), lmsize, qcone, qbetainv, lmsize)
+! dllpmax = 0.0d0
+! do lm1 = 1,lmsize
+! do lm2 = 1,lmsize
+! dllpval = qdllp(lm1,lm2,0)
+! if(abs(dllpval).gt.dllpmax) dllpmax = abs(dllpval)
+! end do
+! end do
+ end if
+
+! write(6,*) 'dllpmax',dllpmax,'iter_beta',iter_beta
+
+ end do ! niter_beta
+
+ if(.not.enable_quad_prec) then
+
+ do ipan = 0, npan
+ do lm1 = 1, lmsize
+ dllp(lm1,lm1,ipan) = dllp(lm1,lm1,ipan) + cone
+ end do
+ end do
+
+ do ipan = 1, npan
+ cllptemp(:, :) = cllp(:, :, ipan)
+ dllptemp(:, :) = dllp(:, :, ipan)
+ cllp(:, :,ipan) = cllptemp(:, :)*(cone+cone)
+ dllp(:, :,ipan) = dllptemp(:, :)*(cone+cone)
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, -cone, cllptemp, lmsize, dllp(1,1,0), lmsize, cone, cllp(1,1,ipan), lmsize)
+ call zgemm('n', 'n', lmsize, lmsize, lmsize, -cone, dllptemp, lmsize, dllp(1,1,0), lmsize, cone, dllp(1,1,ipan), lmsize)
+ end do
+
+ do ipan = 1, npan
+ do icheb = 0, ncheb
+ mn = ipan*ncheb + ipan - icheb
+ call zgemm('n', 'n', lmsize2, lmsize, lmsize, cone, zif(1,1,icheb,ipan), lmsize2, cllp(1,1,ipan), lmsize, czero, sll(1,1,mn), lmsize2)
+ call zgemm('n', 'n', lmsize2, lmsize, lmsize, cone, yif(1,1,icheb,ipan), lmsize2, dllp(1,1,ipan), lmsize, cone, sll(1,1,mn), lmsize2)
end do
end do
- end do
-else
- stop '[vllmatsra] error'
-end if
+ else
+ do ipan = 0, npan
+ do lm1 = 1, lmsize
+ qdllp(lm1,lm1,ipan) = qdllp(lm1,lm1,ipan) + qcone
+ end do
+ end do
+ do ipan = 1, npan
+ qcllptemp(:, :) = qcllp(:, :, ipan)
+ qdllptemp(:, :) = qdllp(:, :, ipan)
+ qcllp(:, :,ipan) = qcllptemp(:, :)*(qcone + qcone)
+ qdllp(:, :,ipan) = qdllptemp(:, :)*(qcone + qcone)
+ call cqgemm(lmsize, lmsize, lmsize, -qcone, qcllptemp, lmsize, qdllp(1,1,0), lmsize, qcone, qcllp(1,1,ipan), lmsize)
+ call cqgemm(lmsize, lmsize, lmsize, -qcone, qdllptemp, lmsize, qdllp(1,1,0), lmsize, qcone, qdllp(1,1,ipan), lmsize)
+ end do
-vll=(0.0D0,0d0)
+ cllp = qcllp
+ do ipan = 1, npan
+ qyif(:,:,:) = yif(:,:,:,ipan)
+ do icheb = 0, ncheb
+ mn = ipan*ncheb + ipan - icheb
+ call zgemm('n', 'n', lmsize2, lmsize, lmsize, cone, zif(1,1,icheb,ipan), lmsize2, cllp(1,1,ipan), lmsize, czero, sll(1,1,mn), lmsize2)
+ call cqgemm(lmsize2, lmsize, lmsize, qcone, qyif(1,1,icheb), lmsize2, qdllp(1,1,ipan), lmsize, qczero, qsll, lmsize2)
+ sll(:,:,mn) = sll(:,:,mn) + qsll(:,:)
+ end do
+ end do
+ end if
+end if
-if (cmode=='Ref=0') then
- vll(1:lmsize,1:lmsize,:)= vll0 !/cvlight
+if(allocated(work)) deallocate( work )
+if(allocated(betainv)) deallocate( betainv )
+if(allocated(betainv_save)) deallocate( betainv_save )
+if(allocated(cllp)) deallocate( cllp )
+if(allocated(dllp)) deallocate( dllp )
+if(allocated(cllptemp)) deallocate( cllptemp )
+if(allocated(dllptemp)) deallocate( dllptemp )
+if(allocated(mihvy)) deallocate( mihvy )
+if(allocated(mihvz)) deallocate( mihvz )
+if(allocated(mijvy)) deallocate( mijvy )
+if(allocated(mijvz)) deallocate( mijvz )
- do ir=1,nrmax
- do ival=1,lmsize
- lval=loflm(ival)
- Mass =cone+(eryd-vll0(ival,ival,ir))/cvlight**2
- Mass0=cone+eryd/cvlight**2
+if(allocated(yif)) deallocate( yif )
+if(allocated(zif)) deallocate( zif )
- !************************************************************************************
- ! Conventional potential matrix
- !************************************************************************************
+if(allocated(qcone)) deallocate (qcone)
+if(allocated(qczero)) deallocate (qczero)
+if(allocated(qmihvy)) deallocate (qmihvy)
+if(allocated(qmihvz)) deallocate (qmihvz)
+if(allocated(qmijvy)) deallocate (qmijvy)
+if(allocated(qmijvz)) deallocate (qmijvz)
+if(allocated(qyif)) deallocate (qyif)
+if(allocated(qbetainv)) deallocate (qbetainv)
+if(allocated(qbetainv_save)) deallocate (qbetainv_save)
+if(allocated(qsll)) deallocate (qsll)
+if(allocated(qcllp)) deallocate (qcllp)
+if(allocated(qdllp)) deallocate (qdllp)
+if(allocated(qcllptemp)) deallocate (qcllptemp)
+if(allocated(qdllptemp)) deallocate (qdllptemp)
+
+end subroutine sll_global_solutions
+
+ SUBROUTINE CQGEMM (M, N, K, ALPHA, A, LDA, B, LDB, BETA, C, LDC )
+ IMPLICIT NONE
+! .. Scalar Arguments ..
+ INTEGER M, N, K, LDA, LDB, LDC
+ COMPLEX*32 ALPHA, BETA
+! .. Array Arguments ..
+ COMPLEX*32 A( LDA, * ), B( LDB, * ), C( LDC, * )
+! ..
+! .. Local Scalars ..
+ COMPLEX*32 TEMP
+ INTEGER I, J, L
+! .. Parameters ..
+ COMPLEX*32 ONE
+ PARAMETER ( ONE = ( 1.0Q+0, 0.0Q+0 ) )
+ COMPLEX*32 ZERO
+ PARAMETER ( ZERO = ( 0.0Q+0, 0.0Q+0 ) )
+! ..
+!
+ IF( ALPHA.EQ.ZERO )THEN
+ IF( BETA.EQ.ZERO )THEN
+ DO 20, J = 1, N
+ DO 10, I = 1, M
+ C( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40, J = 1, N
+ DO 30, I = 1, M
+ C( I, J ) = BETA*C( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+ DO 90, J = 1, N
+ IF( BETA.EQ.ZERO )THEN
+ DO 50, I = 1, M
+ C( I, J ) = ZERO
+ 50 CONTINUE
+ ELSE IF( BETA.NE.ONE )THEN
+ DO 60, I = 1, M
+ C( I, J ) = BETA*C( I, J )
+ 60 CONTINUE
+ END IF
+ DO 80, L = 1, K
+ IF( B( L, J ).NE.ZERO )THEN
+ TEMP = ALPHA*B( L, J )
+ DO 70, I = 1, M
+ C( I, J ) = C( I, J ) + TEMP*A( I, L )
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ RETURN
+ END
+
+ subroutine sll_local_solutions(vll,tau,drpan2,csrc1,slc1sum, &
+ mihvy,mihvz,mijvy,mijvz, &
+ yif,zif, &
+ ncheb,ipan,lmsize,lmsize2,nrmax, &
+ nvec,jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor, &
+ LBESSEL,use_sratrick1)
+implicit none
+ integer :: ncheb ! number of chebyshev nodes
+ integer :: lmsize ! lm-components * nspin
+ integer :: lmsize2 ! lmsize * nvec
+ integer :: nvec ! spinor integer
+! nvec=1 non-rel, nvec=2 for sra and dirac
+ integer :: nrmax ! total number of rad. mesh points
- vll(lmsize+ival,lmsize+ival,ir)= -vll0(ival,ival,ir)/cvlight**2 ! TEST 9/22/2011
- vll(ival,ival,ir)=vll(ival,ival,ir)+ (1.0D0/Mass-1.0D0/Mass0)*lval*(lval+1)/rmesh(ir)**2
+ integer :: LBESSEL, use_sratrick1 ! dimensions etc., needed only for host code interface
- !************************************************************************************
- ! The pertubation matrix is changed in the following way
- !
- ! from / V11 V12 \ to / V21 V22 \
- ! \ V21 V22 / \-V11 -V12 /
- ! because of the convention used for the left solution
- !************************************************************************************
- end do !ival
- end do !ir
-elseif (cmode=='Ref=Vsph') then
- vll(lmsize+1:2*lmsize,1:lmsize,:)=vll0
-endif
+ double complex,parameter:: cone=(1.0d0,0.0d0),czero=(0.0d0,0.0d0)
+! running indices
+ integer ivec, ivec2
+ integer l1,l2,lm1,lm2,lm3
+ integer info,icheb2,icheb,ipan,mn,nplm
-end subroutine vllmatsra
+! source terms
+ double complex :: gmatprefactor ! prefactor of green function
+! non-rel: = kappa = sqrt e
+ DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
+ JLK(LBESSEL,NRMAX), &
+ HLK2(LBESSEL,NRMAX), &
+ JLK2(LBESSEL,NRMAX)
-subroutine rllsllsourceterms(nsra,nvec,eryd,rmesh,nrmax,nrmaxd,lmax,lmsize,use_fullgmat,jlk_index,hlk,jlk,hlk2,jlk2,GMATPREFACTOR)
-implicit none
-! ************************************************************************
-! calculates the source terms J,H and the left solution J2, H2 for:
-! - non-relativistic
-! - scalar-relativistic
-! - full-relativistic
-! calculations
-! ************************************************************************
-double complex,parameter :: ci=(0.0d0,1.0d0)
-double precision :: cvlight
-parameter (cvlight=274.0720442D0)
-integer :: nsra,lmax,nrmax,nrmaxd,nvec
-double complex :: eryd
-double precision :: rmesh(nrmaxd)
-integer :: jlk_index(2*lmsize)
-integer :: l1,lm1,m1,ivec,ispinfullgmat,ir
-integer :: use_fullgmat
-integer :: lmsize
-double complex :: ek,ek2,gmatprefactor
-double complex :: hlk(1:4*(lmax+1),nrmax),jlk(1:4*(lmax+1),nrmax)
-double complex :: hlk2(1:4*(lmax+1),nrmax),jlk2(1:4*(lmax+1),nrmax)
+ INTEGER JLK_INDEX(2*LMSIZE)
-if (nsra==2) then
- nvec=2
-elseif (nsra==1) then
- nvec=1
-end if
+ double complex :: vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7
+
+ double complex :: &
+ mihvy(lmsize,lmsize),mihvz(lmsize,lmsize), &
+ mijvy(lmsize,lmsize),mijvz(lmsize,lmsize), &
+ yif(lmsize2,lmsize,0:ncheb), &
+ zif(lmsize2,lmsize,0:ncheb)
+ double complex :: &
+ srv(0:ncheb,lmsize2,0:ncheb,lmsize2), &
+ srv1(0:ncheb,lmsize,0:ncheb,lmsize), &
+ yill1(0:ncheb,lmsize,lmsize), zill1(0:ncheb,lmsize,lmsize), &
+ yill2(0:ncheb,lmsize,lmsize), zill2(0:ncheb,lmsize,lmsize), &
+ yill(0:ncheb,lmsize2,lmsize), zill(0:ncheb,lmsize2,lmsize), &
+ vjli(lmsize,lmsize2,0:ncheb), vhli(lmsize,lmsize2,0:ncheb), &
+ vjli_yill1(lmsize,lmsize), vhli_yill1(lmsize,lmsize), &
+ vjli_zill1(lmsize,lmsize), vhli_zill1(lmsize,lmsize), &
+ yill1temp(lmsize,lmsize), zill1temp(lmsize,lmsize)
+
+ double complex :: &
+ jlmkmn(0:ncheb,lmsize2,0:ncheb), &
+ hlmkmn(0:ncheb,lmsize2,0:ncheb)
+
+! chebyshev arrays
+ double complex zslc1sum(0:ncheb)
+ double precision drpan2
+ double precision &
+ csrc1(0:ncheb,0:ncheb), & ! Integration matrix from right ( C*S_R*C^-1 in eq. 5.54)
+ tau(0:ncheb), & ! Radial mesh points
+ slc1sum(0:ncheb),taucsrcr,tau_icheb
+ double complex :: gf_tau_icheb
- lm1 = 1
- do ivec=1,nvec
- do ispinfullgmat=0,use_fullgmat
- do l1 = 0,lmax
- do m1 = -l1,l1
- jlk_index(lm1) = l1+(ivec-1)*(lmax+1)+1
- lm1 = lm1 + 1
- end do
- end do
- end do!ispinorbit=0,use_fullgmat
- end do !nvec
+ integer ipiv(0:ncheb,lmsize2)
+ integer :: use_sratrick
+ external zgetrf,zgetrs,zgemm,zcopy
-if (nsra==1) then
- ek = sqrt(eryd)
- ek2 = sqrt(eryd)
-elseif (nsra==2) then
- ek = sqrt(eryd+(eryd/cvlight)**2)
- ek2 = sqrt(eryd+(eryd/cvlight)**2) *(1.0d0+eryd/cvlight**2)
+if ( lmsize==1 ) then
+ use_sratrick=0
+else
+ use_sratrick=use_sratrick1
end if
-
+! initialization
+
+ vhli=czero
+ vjli=czero
-do ir = 1,nrmax
+ if (use_sratrick==0) then
- call beshank(hlk(:,ir),jlk(:,ir),ek*rmesh(ir),lmax)
- if (nsra==2) then
- call beshank_smallcomp(hlk(:,ir),jlk(:,ir),&
- ek*rmesh(ir),rmesh(ir),eryd,lmax)
+ yill=czero
+ zill=czero
+ else
+ yill1=czero
+ zill1=czero
+ yill2=czero
+ zill2=czero
+ end if
+
+!---------------------------------------------------------------------
+! 1. prepare VJLR, VNL, VHLR, which appear in the integrands
+! TAU(K,IPAN) is used instead of TAU(K,IPAN)**2, which directly gives
+! RLL(r) and SLL(r) multiplied with r. TAU is the radial mesh.
+!
+! 2. prepare the source terms YR, ZR, YI, ZI
+! because of the conventions used by
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+! a factor sqrt(E) is included in the source terms
+! this factor is removed by the definition of ZSLC1SUM given below
+!
+!vjlr = \kappa * J * V = \kappa * r * j *V
+!vhlr = \kappa * H * V = \kappa * r * h *V
+!
+! i.e. prepare terms kappa*J*DV, kappa*H*DV appearing in 5.11, 5.12.
+
+ do icheb = 0,ncheb
+ mn = ipan*ncheb + ipan - icheb
+ tau_icheb = tau(icheb)
+ gf_tau_icheb = gmatprefactor*tau_icheb
+
+ do ivec2=1,nvec
+ do lm2 = 1,lmsize
+ do ivec=1,nvec
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1+lmsize*(ivec-1) )
+ vjli(lm1,lm2+lmsize*(ivec2-1),icheb) = vjli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
+ gf_tau_icheb*jlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
+ vhli(lm1,lm2+lmsize*(ivec2-1),icheb) = vhli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
+ gf_tau_icheb*hlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
+ end do
+ end do
+ end do
+ end do !nvec
+
+! calculation of the J (and H) matrix according to equation 5.69 (2nd eq.)
+ if ( use_sratrick==0 ) then
+ do ivec=1,nvec ! index for large/small component
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1+lmsize*(ivec-1) )
+ yill(icheb,lm1+lmsize*(ivec-1),lm1) = tau_icheb*hlk(l1,mn)
+ zill(icheb,lm1+lmsize*(ivec-1),lm1) = tau_icheb*jlk(l1,mn)
+ end do
+ end do !ivec=1,nvec
+ elseif ( use_sratrick==1 ) then
+ do lm1 = 1,lmsize
+ l1 = jlk_index( lm1 )
+ l2 = jlk_index( lm1+lmsize )
+ yill1(icheb,lm1,lm1) = tau_icheb*hlk(l1,mn)
+ zill1(icheb,lm1,lm1) = tau_icheb*jlk(l1,mn)
+ yill2(icheb,lm1,lm1) = tau_icheb*hlk(l2,mn)
+ zill2(icheb,lm1,lm1) = tau_icheb*jlk(l2,mn)
+ end do
end if
+ end do ! icheb
- do l1 = 1,nvec*(lmax+1)
- hlk(l1,ir) = -ci*hlk(l1,ir)
+! calculation of A in 5.68
+ if ( use_sratrick==0 ) then
+ do icheb2 = 0,ncheb
+ do icheb = 0,ncheb
+ taucsrcr = tau(icheb)*csrc1(icheb,icheb2)*drpan2
+ mn = ipan*ncheb + ipan - icheb
+ do lm2 = 1,lmsize2
+ do ivec=1,nvec
+ do lm3 = 1,lmsize
+ lm1=lm3+(ivec-1)*lmsize
+ l1 = jlk_index(lm1)
+ srv(icheb,lm1,icheb2,lm2) = &
+ taucsrcr*(-jlk(l1,mn)*vhli(lm3,lm2,icheb2) &
+ +hlk(l1,mn)*vjli(lm3,lm2,icheb2))
+ end do
+ end do
+ end do
+ end do
end do
-
- if (nsra==1) then
- do l1 = 1,nvec*(lmax+1)
- jlk2(l1,ir) = jlk(l1,ir)
- hlk2(l1,ir) = hlk(l1,ir)
+ do lm1 = 1,lmsize2
+ do icheb = 0,ncheb
+ srv(icheb,lm1,icheb,lm1) = srv(icheb,lm1,icheb,lm1) + 1.d0
end do
- else if (nsra==2) then
- do l1 = 1,lmax+1
- jlk2(l1,ir) = jlk(l1,ir)
- hlk2(l1,ir) = hlk(l1,ir)
end do
- do l1 = lmax+2,2*(lmax+1)
- jlk2(l1,ir) = -jlk(l1,ir)
- hlk2(l1,ir) = -hlk(l1,ir)
+ elseif ( use_sratrick==1 ) then
+ do icheb2 = 0,ncheb
+ do icheb = 0,ncheb
+ taucsrcr = tau(icheb)*csrc1(icheb,icheb2)*drpan2
+ mn = ipan*ncheb + ipan - icheb
+ do lm1 = 1,lmsize
+ l1 = jlk_index(lm1)
+ jlmkmn(icheb,lm1,icheb2) = taucsrcr*jlk(l1,mn)
+ hlmkmn(icheb,lm1,icheb2) = taucsrcr*hlk(l1,mn)
+ end do
+ end do
+ end do
+ do lm2 = 1,lmsize
+ do icheb2 = 0,ncheb
+ do lm1 = 1,lmsize
+ do icheb = 0,ncheb
+ srv1(icheb,lm1,icheb2,lm2) = &
+ -jlmkmn(icheb,lm1,icheb2)*vhli(lm1,lm2,icheb2) &
+ +hlmkmn(icheb,lm1,icheb2)*vjli(lm1,lm2,icheb2)
+ end do
+ end do
+ end do
+ end do
+ do lm1 = 1,lmsize
+ do icheb = 0,ncheb
+ srv1(icheb,lm1,icheb,lm1) = srv1(icheb,lm1,icheb,lm1) + 1.d0
+ end do
end do
- end if
-
-end do
-gmatprefactor=ek2
-end subroutine rllsllsourceterms
-
-SUBROUTINE calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,z,c,e, &
- rnew,vins,ncheb,npan_tot,rpan_intervall, &
- jlk_index,hlk,jlk,hlk2,jlk2,gmatprefactor,tmat, &
- use_sratrick)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-18 Time: 14:28:30
-
-IMPLICIT NONE
-
-INTEGER, INTENT(IN) :: nsra
-INTEGER, INTENT(IN) :: irmdnew
-INTEGER, INTENT(IN OUT) :: nrmaxd
-INTEGER, INTENT(IN) :: lmax
-INTEGER, INTENT(IN) :: nspin
-DOUBLE PRECISION, INTENT(IN) :: z
-DOUBLE PRECISION, INTENT(IN) :: c
-DOUBLE COMPLEX, INTENT(OUT) :: e
-!INTEGER, INTENT(IN) :: lmpotd
-!INTEGER, INTENT(IN OUT) :: lmmaxso
-DOUBLE PRECISION, INTENT(IN) :: rnew(:)
-DOUBLE PRECISION, INTENT(IN) :: vins(:,:,:)
-INTEGER, INTENT(IN) :: ncheb
-INTEGER, INTENT(IN) :: npan_tot
-DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
-INTEGER, INTENT(OUT) :: jlk_index(:)
-DOUBLE COMPLEX, INTENT(IN OUT) :: hlk(:,:)
-DOUBLE COMPLEX, INTENT(IN OUT) :: jlk(:,:)
-DOUBLE COMPLEX, INTENT(IN OUT) :: hlk2(:,:)
-DOUBLE COMPLEX, INTENT(IN OUT) :: jlk2(:,:)
-DOUBLE COMPLEX, INTENT(IN OUT) :: gmatprefactor
-DOUBLE COMPLEX, INTENT(IN OUT) :: tmat(:)
-INTEGER, INTENT(IN OUT) :: use_sratrick
-! construct wavefunctions for spherical potentials
-
-
-! local
-INTEGER :: lmsize,lmsize2,nvec
-INTEGER :: ivec,lval,ir,ispin,lspin,lsra,i,l1,m1,lm1
-INTEGER, allocatable :: jlk_indextemp(:)
-DOUBLE COMPLEX, allocatable :: vll0(:,:,:)
-DOUBLE COMPLEX, allocatable :: vll(:,:,:)
-DOUBLE COMPLEX, allocatable :: rlltemp(:,:,:),slltemp(:,:,:), &
- hlktemp(:,:),jlktemp(:,:), hlk2temp(:,:),jlk2temp(:,:), &
- hlknew(:,:),jlknew(:,:)
-DOUBLE COMPLEX, allocatable :: tmattemp(:,:)
-
-lmsize=1
-IF (nsra == 2) THEN
- lmsize2=2
- nvec=2
-ELSE
- lmsize2=1
- nvec=1
-END IF
-allocate (rlltemp(lmsize2,lmsize,irmdnew))
-allocate (slltemp(lmsize2,lmsize,irmdnew))
-allocate (hlktemp(nvec,irmdnew))
-allocate (jlktemp(nvec,irmdnew))
-allocate (hlk2temp(nvec,irmdnew))
-allocate (jlk2temp(nvec,irmdnew))
-allocate (jlk_indextemp(lmsize2))
-allocate (tmattemp(lmsize,lmsize))
-allocate (hlknew(nvec*nspin*(lmax+1),irmdnew))
-allocate (jlknew(nvec*nspin*(lmax+1),irmdnew))
-
-DO ivec=1,nvec
- jlk_indextemp(ivec)=ivec
-END DO
-allocate(vll0(lmsize,lmsize,irmdnew))
-IF (nsra == 2) THEN
- allocate(vll(2*lmsize,2*lmsize,irmdnew))
-ELSE
- allocate(vll(lmsize,lmsize,irmdnew))
-END IF
-! spin loop
-DO ispin=1,nspin
-
- lspin=(lmax+1)*(ispin-1)
- lsra=(lmax+1)*nvec
-! each value of l, the Lippmann-Schwinger equation is solved using
-! the free-potential wavefunctions and potentials corresponding to l-value
- DO lval=0,lmax
-
- DO ir=1,irmdnew
- vll0(lmsize,lmsize,ir)=vins(ir,1,ispin)-2D0*z/rnew(ir)
- END DO
-
- IF (nsra == 2) THEN
- CALL vllmatsra(vll0,vll,rnew,lmsize,irmdnew,nrmaxd, &
- e,c,lmax,lval,'Ref=0')
- ELSE
- vll(:,:,:)=vll0(:,:,:)
- END IF
-
- jlktemp(1,:)=jlk(lval+1,:)
- hlktemp(1,:)=hlk(lval+1,:)
- jlk2temp(1,:)=jlk2(lval+1,:)
- hlk2temp(1,:)=hlk2(lval+1,:)
- IF (nsra == 2) THEN
- jlktemp(2,:)=jlk(lmax+lval+2,:)
- hlktemp(2,:)=hlk(lmax+lval+2,:)
- jlk2temp(2,:)=jlk2(lmax+lval+2,:)
- hlk2temp(2,:)=hlk2(lmax+lval+2,:)
- END IF
- CALL rllsll(rpan_intervall,rnew,vll,rlltemp,slltemp,tmattemp, &
- ncheb,npan_tot,lmsize,lmsize2,nvec,irmdnew,nvec, &
- jlk_indextemp,hlktemp,jlktemp,hlk2temp,jlk2temp, &
- gmatprefactor,'1','1',use_sratrick)
-
- DO ir=1,irmdnew
- hlknew(lspin+lval+1,ir)=slltemp(1,1,ir)/rnew(ir)
- jlknew(lspin+lval+1,ir)=rlltemp(1,1,ir)/rnew(ir)
- END DO
- IF (nsra == 2) THEN
- DO ir=1,irmdnew
- hlknew(lspin+lsra+lval+1,ir)=slltemp(2,1,ir)/rnew(ir)
- jlknew(lspin+lsra+lval+1,ir)=rlltemp(2,1,ir)/rnew(ir)
- END DO
- END IF
- tmat(lspin+lval+1)=tmattemp(1,1)
- END DO ! LMAX
-END DO ! NSPIN
-
-lm1=1
-DO ivec=1,nvec
- DO i=1,2
- DO l1=0,lmax
- DO m1=-l1,l1
- jlk_index(lm1)=l1+(ivec-1)*nspin*(lmax+1)+(i-1)*(lmax+1)+1
- lm1=lm1+1
- END DO
- END DO
- END DO
-END DO
-DO ir=1,irmdnew
- DO l1=1,nvec*(lmax+1)*nspin
- hlk(l1,ir)=hlknew(l1,ir)
- jlk(l1,ir)=jlknew(l1,ir)
- END DO
-END DO
-IF (nsra == 2) THEN
- DO ir=1,irmdnew
- DO l1=1,(lmax+1)*nspin
- hlk2(l1,ir)=-hlknew(l1+lmax+1,ir)
- jlk2(l1,ir)=-jlknew(l1+lmax+1,ir)
- END DO
- DO l1=nspin*(lmax+1)+1,nvec*(lmax+1)*nspin
- hlk2(l1,ir)=hlknew(l1-(lmax+1)*nspin,ir)
- jlk2(l1,ir)=jlknew(l1-(lmax+1)*nspin,ir)
- END DO
- END DO
-ELSE
- DO ir=1,irmdnew
- DO l1=1,nvec*(lmax+1)*nspin
- hlk2(l1,ir)=-hlknew(l1,ir)
- jlk2(l1,ir)=-jlknew(l1,ir)
- END DO
- END DO
-END IF
-
-deallocate (rlltemp)
-deallocate (slltemp)
-deallocate (hlktemp)
-deallocate (jlktemp)
-deallocate (hlk2temp)
-deallocate (jlk2temp)
-deallocate (jlk_indextemp)
-deallocate (tmattemp)
-deallocate (hlknew)
-deallocate (jlknew)
-deallocate (vll0)
-deallocate (vll)
-END SUBROUTINE calcsph
-
-#define hostcode ! comment this out to use the impurity code interface
-! choose between interface for impurity and host code (different calling lists)
-#ifndef hostcode
- MODULE MOD_RLL_ONLY
- CONTAINS
- SUBROUTINE RLL_ONLY(RPANBOUND,RMESH,VLL,RLL,TLLP, &
- NCHEB,NPAN,LMSIZE,LMSIZE2,NRMAX, &
- nvec,jlk_index,hlk,jlk,hlk2,jlk2,GMATPREFACTOR, &
- cmoderll,cmodesll,cmodetest,idotime)
-#else
- SUBROUTINE RLL_ONLY(RPANBOUND,RMESH,VLL,RLL,TLLP, &
- NCHEB,NPAN,LMSIZE,LMSIZE2,LBESSEL,NRMAX, &
- NVEC,JLK_INDEX,HLK,JLK,HLK2,JLK2,GMATPREFACTOR, &
- CMODERLL,CMODESLL,USE_SRATRICK1) ! &
- ! ALPHAGET) ! LLY
-#endif
-! ************************************************************************
-! radial wave functions by the integral equation method of
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-! which has been extended for KKR using non-sperical potentials.
-! Further information can be found in
-!
-! David Bauer,
-! "Development of a relativistic full-potential first-principles multiple scattering
-! Green function method applied to complex magnetic textures of nano structures
-! at surfaces", PhD Thesis, 2014
-!
-! http://darwin.bth.rwth-aachen.de/opus3/volltexte/2014/4925/
-!
-!
-!
-! ************************************************************************
-! This routine solves the following two equations:
-!
-! ULL(r) = J(r) - PRE * J(r) * int_0^r( dr' r'^2 H2(r') * op(V(r')) * ULL(r') )
-! + PRE * H(r) * int_0^r( dr' r'^2 J2(r') * op(V(r')) * ULL(r') )
-!
-! where the integral int_0^r() runs from 0 to r
-! ************************************************************************
-! Potential matrix : VLL(LMSIZE*NVEC,LMSIZE*NVEC)
-! LMSIZE = LMMAX (number of LM components) x Number of spin components
-! LMSIZE2 = NVEC* LMSIZE
-! NVEC is 2 for a spinor and 1 in case of a non-rel. calculation
-!
-! ************************************************************************
-! Green function prefacor PRE=GMATPREFACTOR (scalar value)
-! tipically \kappa for non-relativistic and M_0 \kappa for SRA
-!
-! ************************************************************************
-
-
-! ************************************************************************
-! The discretization of the Lippmann-Schwinger equation results in a matrix
-! equation which is solved in this routine. Further information is given
-! in section 5.2.3, page 90 of Bauer, PhD
-!
-! Source terms :
-! right solution: J, H (nvec*lmsize,lmsize) or (lmsize,nvec*lmsize)
-! left solution: J2,H2 (lmsize,nvec*lmsize) or (nvec*lmsize,lmsize)
-!
-! Example:
-! The source term J is for LMSIZE=3 and NVEC=2 given by:
-! J = / jlk(jlk_index(1)) \
-! | 0 jlk(jlk_index(2)) |
-! | 0 0 jlk(jlk_index(3)) |
-! | jlk(jlk_index(4)) |
-! | 0 jlk(jlk_index(5)) |
-! \ 0 0 jlk(jlk_index(6)) /
-!
-! first 3 rows are for the large and the last 3 rows for the small component
-! ************************************************************************
-! Operator op() can be chosen to be a unity or a transpose operation
-! The unity operation is used to calculate the right solution
-! The transpose operation is used to calculate the left solution
-! ************************************************************************
-! RMESH - radial mesh
-! RPANBOUND - panel bounds RPANBOUND(0) left panel border of panel 1
-! RPANBOUND(1) right panel border of panel 1
-! NCHEB - highes chebyshev polynomial
-! number of points per panel = NCHEB + 1
-! NPAN - number of panels
-! LMSIZE - number of colums for the source matrix J etc...
-! LMSIZE2 - number of rows for the source matrix J etc...
-! NRMAX - total number of radial points (NPAN*(NCHEB+1))
-! NVEC - number of LMSIZE*LMSIZE blocks in J (LMSIZE2=NVEC*LMSIZE)
-! ************************************************************************
-#ifndef hostcode
-use mod_beshank ! calculates bessel and hankel func.
-use mod_chebint ! chebyshev integration routines
-use mod_config, only: config_testflag ! reads if testflags are present
-use mod_physic_params,only: cvlight ! speed of light
-use sourceterms
-use mod_chebyshev
-#endif
-!use mod_timing ! timing routine
-#ifdef CPP_hybrid
-!use omp_lib ! omp functions
-#endif
-implicit none
- integer :: ncheb ! number of chebyshev nodes
- integer :: npan ! number of panels
- integer :: lmsize ! lm-components * nspin
- integer :: lmsize2 ! lmsize * nvec
- integer :: nvec ! spinor integer
- ! nvec=1 non-rel, nvec=2 for sra and dirac
- integer :: nrmax ! total number of rad. mesh points
-#ifdef hostcode
- integer :: LBESSEL, use_sratrick1 ! dimensions etc., needed only for host code interface
-#endif
-
- double complex,parameter:: ci= (0.0d0,1.0d0), &! complex i
- cone=(1.0d0,0.0d0),&! 1
- czero=(0.0d0,0.0d0) ! 0
- ! running indices
- integer ivec, ivec2
- integer l1,l2,lm1,lm2,lm3
- integer info,icheb2,icheb,ipan,mn,nm,nplm
-
- ! source terms
- double complex :: gmatprefactor ! prefactor of green function
- ! non-rel: = kappa = sqrt e
-#ifndef hostcode
- double complex :: hlk(:,:), jlk(:,:), & ! right sol. source terms
- hlk2(:,:), jlk2(:,:) ! left sol. source terms
- ! (tipically bessel and hankel fn)
-#else
- DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
- JLK(LBESSEL,NRMAX), &
- HLK2(LBESSEL,NRMAX), &
- JLK2(LBESSEL,NRMAX)
-#endif
-
-#ifndef hostcode
- integer jlk_index(:) ! mapping array l = jlk_index(lm)
- ! in: lm-index
- ! corresponding l-index used hlk,..
- ! hlk(l) = jlk_index(lm)
-#else
- INTEGER JLK_INDEX(2*LMSIZE)
-#endif
-
- character(len=1) :: cmoderll,cmodesll,cmodetest ! These define the op(V(r)) in the eqs. above
- ! (comment in the beginning of this subroutine)
- ! cmoderll ="1" : op( )=identity for reg. solution
- ! cmoderll ="T" : op( )=transpose in L for reg. solution
- ! cmodesll: same for irregular
-
- double complex :: rll(lmsize2,lmsize,nrmax), & ! reg. fredholm sol.
- tllp(lmsize,lmsize), & ! t-matrix
- vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7
- ! bauer, phd
- double complex,allocatable :: ull(:,:,:) ! reg. volterra sol.
-
- double complex,allocatable :: &
- work(:,:), &
- work2(:,:), &
- allp(:,:,:),bllp(:,:,:), & ! eq. 5.9, 5.10 for reg. sol
- slv(:,:,:,:), & ! a in eq 5.68
- slv1(:,:,:,:), & !****************
-! slv2(:,:,:,:), & ! used for sra trick
- mrnvy(:,:,:),mrnvz(:,:,:), & ! ***************
- mrjvy(:,:,:),mrjvz(:,:,:), & ! eq. 5.19-5.22
- yrll(:,:,:),zrll(:,:,:), & !
- yrll1(:,:,:),zrll1(:,:,:), &
- yrll2(:,:,:),zrll2(:,:,:), &
- vhlr(:,:,:), & ! vhlr = h * v (regular sol.)
- vjlr(:,:,:) ! vjlr = j * v (regular sol.)
- double complex,allocatable :: &
- vhlr_yrll1(:,:), & !
- vhlr_zrll1(:,:), & !
- vjlr_yrll1(:,:), & !
- vjlr_zrll1(:,:), & !
- yrll1temp(:,:), & !
- zrll1temp(:,:) !
- double complex,allocatable :: yrf(:,:,:,:), & ! source terms (different array
- zrf(:,:,:,:) ! ordering)
- ! chebyshev arrays
- double complex zslc1sum(0:ncheb)
- double precision c1(0:ncheb,0:ncheb),rpanbound(0:npan)
- double precision cslc1(0:ncheb,0:ncheb), & ! Integration matrix from left ( C*S_L*C^-1 in eq. 5.53)
- csrc1(0:ncheb,0:ncheb), & ! Same from right ( C*S_R*C^-1 in eq. 5.54)
- tau(0:ncheb,0:npan), & ! Radial mesh point
- slc1sum(0:ncheb),rmesh(nrmax),taucslcr
-
- integer ipiv(0:ncheb,lmsize2)
- integer,allocatable :: ipiv2(:)
-! logical test
-! integer :: ierror
- integer :: use_sratrick
-! integer :: idotime
- integer,parameter :: directsolv=1
-#ifdef hostcode
-! DOUBLE COMPLEX ALPHAGET(LMSIZE,LMSIZE) ! LLY
-#endif
-
-#ifdef CPP_hybrid
-! openMP variable --sacin 23/04/2015
-! integer :: thread_id, number_of_openmp_threads,number_of_processor
-#endif
-
- external zgetrf,zgetrs
- intrinsic abs,atan,cos,dimag,exp,max,min,sin,sqrt
-
-! ***********************************************************************
-! SRA trick
-! ***********************************************************************
-! on page 68 of Bauer, PhD, a method is described how to speed up the
-! calculations in case of the SRA. A similar approach is implemented
-! here by using Eq. 4.132 and substituting DV from 4.133, and discretising
-! the radial mesh of the Lippmann-Schwinger eq. according to 5.68.
-! The Lippmann-Schwinger equation leads to a matrix inversion
-! problem. The matrix M which needs to be inverted has a special form
-! if the SRA approximation is used:
-!
-! matrix A ( C 0) (same as in eq. 5.68)
-! ( B 1)
-! (C, B are matricies here)
-!
-! inverse of A is (C^-1 0 )
-! (-B C^-1 1 )
-! Thus, it is sufficient to only inverse the matrix C which saves computational
-! time. This is refered to as the SRA trick.
-! ***********************************************************************
-! in future implementation equation 4.134 is supposed to be
-! implemented which should lead to an additional speed-up.
-! ***********************************************************************
-
-#ifndef hostcode
-if ( config_testflag('nosph') .or. lmsize==1 ) then
- use_sratrick=0
-elseif ( .not. config_testflag('nosph') ) then
- use_sratrick=1
-else
- stop '[rll] use_sratrick error'
-end if
-#else
-if ( lmsize==1 ) then
- use_sratrick=0
-else
- use_sratrick=use_sratrick1
-end if
-#endif
-
-!#ifdef hostcode
-!! turn timing output off if in the host code
-!idotime = 0
-!#endif
-!if (idotime==1) call timing_start('rll')
-
-
-do ipan = 1,npan
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- tau(icheb,ipan) = rmesh(mn)
- end do
-end do
-
-call chebint(cslc1,csrc1,slc1sum,c1,ncheb)
-
-
-
-if(.not.allocated(ull)) allocate ( ull(lmsize2,lmsize,nrmax) )
-
-if ( use_sratrick==0 ) then
- if(.not.allocated(slv)) allocate ( slv(0:ncheb,lmsize2,0:ncheb,lmsize2) )
-elseif ( use_sratrick==1 ) then
- if(.not.allocated(work2)) allocate ( work2((ncheb+1)*lmsize,(ncheb+1)*lmsize), ipiv2((ncheb+1)*lmsize) )
- if(.not.allocated(slv1)) allocate ( slv1(0:ncheb,lmsize,0:ncheb,lmsize) )
-! if(.not.allocated(slv2)) allocate ( slv2(0:ncheb,lmsize,0:ncheb,lmsize) )
- if(.not.allocated(yrll1)) allocate ( yrll1(0:ncheb,lmsize,lmsize), zrll1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll2)) allocate ( yrll2(0:ncheb,lmsize,lmsize), zrll2(0:ncheb,lmsize,lmsize) )
-else
- stop '[rll] error with testflag sph'
-end if
-
-if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
-if(.not.allocated(allp)) allocate( allp(lmsize,lmsize,0:npan), bllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(mrnvy)) allocate( mrnvy(lmsize,lmsize,npan), mrnvz(lmsize,lmsize,npan) )
-if(.not.allocated(mrjvy)) allocate( mrjvy(lmsize,lmsize,npan), mrjvz(lmsize,lmsize,npan) )
-if(.not.allocated(yrll)) allocate( yrll(0:ncheb,lmsize2,lmsize), zrll(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(vjlr)) allocate( vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb) )
-
-yrll=(0.0d0,0.0d0)
-yrll=(0.0d0,0.0d0)
-
-if(.not.allocated(yrf)) allocate( yrf(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zrf)) allocate( zrf(lmsize2,lmsize,0:ncheb,npan) )
-
-
-
-#ifdef CPP_hybrid
-!call omp_set_num_threads(16)
-!number_of_openmp_threads = omp_get_num_threads()
-!write(*,*) 'number_of_openmp_threads: ', number_of_openmp_threads
-!$NOOMP PARALLEL DEFAULT (PRIVATE) &
-!$NOOMP& SHARED(tau,npan,rpanbound,mrnvy,mrnvz,mrjvy,mrjvz,yrf, &
-!$NOOMP& zrf,nvec,lmsize,lmsize2,ncheb,jlk,jlk2,jlk_index,vll,gmatprefactor,hlk,hlk2,cslc1,csrc1,slc1sum, &
-!$NOOMP& cmoderll,cmodesll,cmodetest,use_sratrick, rmesh)
-
-!thread_id = omp_get_thread_num()
-#endif
-
-if(.not.allocated(ull)) allocate ( ull(lmsize2,lmsize,nrmax) )
-
-if ( use_sratrick==0 ) then
- if(.not.allocated(slv)) allocate ( slv(0:ncheb,lmsize2,0:ncheb,lmsize2) )
-elseif ( use_sratrick==1 ) then
- if(.not.allocated(work2)) allocate ( work2((ncheb+1)*lmsize,(ncheb+1)*lmsize), ipiv2((ncheb+1)*lmsize) )
- if(.not.allocated(slv1)) allocate ( slv1(0:ncheb,lmsize,0:ncheb,lmsize) )
-! if(.not.allocated(slv2)) allocate ( slv2(0:ncheb,lmsize,0:ncheb,lmsize) )
- if(.not.allocated(yrll1)) allocate ( yrll1(0:ncheb,lmsize,lmsize), zrll1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll2)) allocate ( yrll2(0:ncheb,lmsize,lmsize), zrll2(0:ncheb,lmsize,lmsize) )
-else
- stop '[rll] error with testflag sph'
-end if
-
-if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
-if(.not.allocated(allp)) allocate( allp(lmsize,lmsize,0:npan), bllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(mrnvy)) allocate( mrnvy(lmsize,lmsize,npan), mrnvz(lmsize,lmsize,npan) )
-if(.not.allocated(mrjvy)) allocate( mrjvy(lmsize,lmsize,npan), mrjvz(lmsize,lmsize,npan) )
-if(.not.allocated(yrll)) allocate( yrll(0:ncheb,lmsize2,lmsize), zrll(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(vjlr)) allocate( vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb) )
-if(.not.allocated(vjlr_yrll1)) allocate( vjlr_yrll1(lmsize,lmsize), vhlr_yrll1(lmsize,lmsize) )
-if(.not.allocated(vjlr_zrll1)) allocate( vjlr_zrll1(lmsize,lmsize), vhlr_zrll1(lmsize,lmsize) )
-if(.not.allocated(yrll1temp)) allocate( yrll1temp(lmsize,lmsize), zrll1temp(lmsize,lmsize) )
-
-yrll=(0.0d0,0.0d0)
-yrll=(0.0d0,0.0d0)
-
-if(.not.allocated(yrf)) allocate( yrf(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zrf)) allocate( zrf(lmsize2,lmsize,0:ncheb,npan) )
-
-!if (idotime==1) call timing_start('local')
-
-! loop over subintervals
-#ifdef CPP_hybrid
-! openMP pragmas added sachin, parallel region starts earlier to get allocations of arrays right
-!$NOOMP DO
-#endif
-do ipan = 1,npan
-
-! if (idotime==1) call timing_start('local1')
-
- ! initialization
-
- vhlr=czero
- vjlr=czero
-
- if (use_sratrick==0) then
-
- yrll=czero
- zrll=czero
- else
- yrll1=czero
- zrll1=czero
- yrll2=czero
- zrll2=czero
- end if
-
-!---------------------------------------------------------------------
-! 1. prepare VJLR, VNL, VHLR, which appear in the integrands
-! TAU(K,IPAN) is used instead of TAU(K,IPAN)**2, which directly gives
-! RLL(r) multiplied with r. TAU is the radial mesh.
-!
-! 2. prepare the source terms YR, ZR
-! because of the conventions used by
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-! a factor sqrt(E) is included in the source terms
-! this factor is removed by the definition of ZSLC1SUM given below
-!
-!vjlr = \kappa * J * V = \kappa * r * j *V
-!vhlr = \kappa * H * V = \kappa * r * h *V
-!
-! i.e. prepare terms kappa*J*DV, kappa*H*DV appearing in 5.11, 5.12.
-
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- if (cmoderll=='1') then
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do
- elseif (cmoderll=='T') then ! transposed matrix (might not be needed anymore)
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do !nvec
- elseif (cmoderll=='0') then ! as a test option
- vjlr(:,:,icheb) = czero
- vhlr(:,:,icheb) = czero
- else
- stop '[rll] mode not known'
- end if
-
- ! calculation of the J (and H) matrix according to equation 5.69 (2nd eq.)
- if ( use_sratrick==0 ) then
- do ivec=1,nvec ! index for large/small component
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- yrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- zrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- end do
- end do !ivec=1,nvec
- elseif ( use_sratrick==1 ) then
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(1-1) )
- l2 = jlk_index( lm1+lmsize*(2-1) )
- yrll1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- zrll1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- yrll2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l2,mn)
- zrll2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l2,mn)
- end do
- end if
- end do ! icheb
-
- ! calculation of A in 5.68
- if ( use_sratrick==0 ) then
- do icheb2 = 0,ncheb
- do icheb = 0,ncheb
- taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
- mn = ipan*ncheb + ipan - icheb
- do lm2 = 1,lmsize2
- do ivec=1,nvec
- do lm3 = 1,lmsize
- lm1=lm3+(ivec-1)*lmsize
- l1 = jlk_index(lm1)
- slv(icheb,lm1,icheb2,lm2) = &
- taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
- -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
- end do
- end do
- end do
- end do
- end do
- do lm1 = 1,lmsize2
- do icheb = 0,ncheb
- slv(icheb,lm1,icheb,lm1) = slv(icheb,lm1,icheb,lm1) + 1.d0
- end do
- end do
- elseif ( use_sratrick==1 ) then
- do icheb2 = 0,ncheb
- do icheb = 0,ncheb
- taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
- mn = ipan*ncheb + ipan - icheb
- do lm2 = 1,lmsize
-! do ivec=1,1
- do lm3 = 1,lmsize
-! lm1=lm3+(ivec-1)*lmsize
- lm1=lm3
- l1 = jlk_index(lm1)
-
- ! this is the block to be inverted in SRAtrick. (named C in comment above):
- slv1(icheb,lm1,icheb2,lm2) = &
- taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
- -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
-
- end do
-! end do
- end do
- end do
- end do
-! do icheb2 = 0,ncheb
-! do icheb = 0,ncheb
-! taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
-! *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
-! mn = ipan*ncheb + ipan - icheb
-! do lm2 = 1,lmsize
-! do ivec=2,2
-! do lm3 = 1,lmsize
-! lm1=lm3+(ivec-1)*lmsize
-! lm1=lm3+lmsize
-! l1 = jlk_index(lm1)
-
-! slv2(icheb,lm3,icheb2,lm2) = &
-! taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
-! -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
-
-! end do
-! end do
-! end do
-! end do
-! end do
- do lm1 = 1,lmsize
- do icheb = 0,ncheb
- slv1(icheb,lm1,icheb,lm1) = slv1(icheb,lm1,icheb,lm1) + 1.d0
- end do
- end do
-
- else
- stop '[rll] error in inversion'
- end if
-
-! if (idotime==1) call timing_pause('local1')
-! if (idotime==1) call timing_start('local2')
+ else
+ stop '[rllsll] error in inversion'
+ end if
!-------------------------------------------------------
! determine the local solutions
-! solve the equations SLV*YRLL=S and SLV*ZRLL=C
+! solve the equations SLV*YRLL=S and SLV*ZRLL=C
! and SRV*YILL=C and SRV*ZILL=S
! i.e., solve system A*U=J, see eq. 5.68.
if ( use_sratrick==0 ) then
nplm = (ncheb+1)*lmsize2
- if (cmoderll/='0') then
-! if (idotime==1) call timing_start('inversion')
- call zgetrf(nplm,nplm,slv,nplm,ipiv,info)
-! if (idotime==1) call timing_stop('inversion','test')
- if (info/=0) stop 'rll: zgetrf'
- call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,yrll,nplm,info)
- call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,zrll,nplm,info)
- end if
+ call zgetrf(nplm,nplm,srv,nplm,ipiv,info)
+ if (info/=0) stop 'rllsll: zgetrf'
+ call zgetrs('n',nplm,lmsize,srv,nplm,ipiv,yill,nplm,info)
+ call zgetrs('n',nplm,lmsize,srv,nplm,ipiv,zill,nplm,info)
elseif ( use_sratrick==1 ) then
nplm = (ncheb+1)*lmsize
- call zgetrf(nplm,nplm,slv1,nplm,ipiv,info)
- call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,yrll1,nplm,info)
- call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,zrll1,nplm,info)
-
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,slv2, &
-! nplm,yrll1,nplm,cone,yrll2,nplm)
-
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,slv2, &
-! nplm,zrll1,nplm,cone,zrll2,nplm)
+ call zgetrf(nplm,nplm,srv1,nplm,ipiv,info)
+ call zgetrs('n',nplm,lmsize,srv1,nplm,ipiv,yill1,nplm,info)
+ call zgetrs('n',nplm,lmsize,srv1,nplm,ipiv,zill1,nplm,info)
do icheb2 = 0,ncheb
do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- yrll1temp(lm1,lm2) = yrll1(icheb2,lm1,lm2)
- zrll1temp(lm1,lm2) = zrll1(icheb2,lm1,lm2)
+ do lm1 = 1,lmsize
+ yill1temp(lm1,lm2) = yill1(icheb2,lm1,lm2)
+ zill1temp(lm1,lm2) = zill1(icheb2,lm1,lm2)
end do
end do
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
- lmsize,yrll1temp,lmsize,czero,vhlr_yrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
- lmsize,zrll1temp,lmsize,czero,vhlr_zrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
- lmsize,yrll1temp,lmsize,czero,vjlr_yrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
- lmsize,zrll1temp,lmsize,czero,vjlr_zrll1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhli(1,1,icheb2), &
+ lmsize,yill1temp,lmsize,czero,vhli_yill1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhli(1,1,icheb2), &
+ lmsize,zill1temp,lmsize,czero,vhli_zill1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjli(1,1,icheb2), &
+ lmsize,yill1temp,lmsize,czero,vjli_yill1,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjli(1,1,icheb2), &
+ lmsize,zill1temp,lmsize,czero,vjli_zill1,lmsize)
do icheb = 0,ncheb
- taucslcr = - tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
+ taucsrcr = tau(icheb)*csrc1(icheb,icheb2)*drpan2
mn = ipan*ncheb + ipan - icheb
do lm2 = 1,lmsize
do lm3 = 1,lmsize
lm1=lm3+lmsize
l1 = jlk_index(lm1)
- yrll2(icheb,lm3,lm2) = &
- yrll2(icheb,lm3,lm2) + &
- taucslcr*(jlk(l1,mn)*vhlr_yrll1(lm3,lm2) &
- -hlk(l1,mn)*vjlr_yrll1(lm3,lm2))
+ yill2(icheb,lm3,lm2) = &
+ yill2(icheb,lm3,lm2) + &
+ taucsrcr*(jlk(l1,mn)*vhli_yill1(lm3,lm2) &
+ -hlk(l1,mn)*vjli_yill1(lm3,lm2))
- zrll2(icheb,lm3,lm2) = &
- zrll2(icheb,lm3,lm2) + &
- taucslcr*(jlk(l1,mn)*vhlr_zrll1(lm3,lm2) &
- -hlk(l1,mn)*vjlr_zrll1(lm3,lm2))
+ zill2(icheb,lm3,lm2) = &
+ zill2(icheb,lm3,lm2) + &
+ taucsrcr*(jlk(l1,mn)*vhli_zill1(lm3,lm2) &
+ -hlk(l1,mn)*vjli_zill1(lm3,lm2))
end do
end do
@@ -2830,16 +2701,16 @@ do ipan = 1,npan
end do
else
- stop '[rll] error in inversion'
+ stop '[rllsll] error in inversion'
end if
- ! Reorient indices for later use
+! Reorient indices for later use
if ( use_sratrick==0 ) then
do icheb = 0,ncheb
do lm2 = 1,lmsize
do lm1 = 1,lmsize2
- yrf(lm1,lm2,icheb,ipan) = yrll(icheb,lm1,lm2)
- zrf(lm1,lm2,icheb,ipan) = zrll(icheb,lm1,lm2)
+ yif(lm1,lm2,icheb) = yill(icheb,lm1,lm2)
+ zif(lm1,lm2,icheb) = zill(icheb,lm1,lm2)
end do
end do
end do
@@ -2849,2943 +2720,2028 @@ do ipan = 1,npan
do icheb = 0,ncheb
do lm2 = 1,lmsize
do lm1 = 1,lmsize
- yrf(lm1,lm2,icheb,ipan) = yrll1(icheb,lm1,lm2)
- zrf(lm1,lm2,icheb,ipan) = zrll1(icheb,lm1,lm2)
- end do
- end do
- end do
-
- do icheb = 0,ncheb
- do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- yrf(lm1+lmsize,lm2,icheb,ipan) = yrll2(icheb,lm1,lm2)
- zrf(lm1+lmsize,lm2,icheb,ipan) = zrll2(icheb,lm1,lm2)
+ yif(lm1,lm2,icheb) = yill1(icheb,lm1,lm2)
+ zif(lm1,lm2,icheb) = zill1(icheb,lm1,lm2)
+ yif(lm1+lmsize,lm2,icheb) = yill2(icheb,lm1,lm2)
+ zif(lm1+lmsize,lm2,icheb) = zill2(icheb,lm1,lm2)
end do
end do
end do
end if
-! if (idotime==1) call timing_pause('local2')
-! if (idotime==1) call timing_start('local3')
-
- ! Calculation of eq. 5.19-5.22
+! Calculation of eq. 5.19-5.22
do icheb = 0,ncheb
- zslc1sum(icheb) = slc1sum(icheb) * (rpanbound(ipan)-rpanbound(ipan-1))/ (2.d0)
+ zslc1sum(icheb) = slc1sum(icheb)*drpan2
end do
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
- lmsize,yrf(1,1,0,ipan),lmsize2,czero,mrnvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
- lmsize,yrf(1,1,0,ipan),lmsize2,czero,mrjvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
- lmsize,zrf(1,1,0,ipan),lmsize2,czero,mrnvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
- lmsize,zrf(1,1,0,ipan),lmsize2,czero,mrjvz(1,1,ipan),lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhli(1,1,0), &
+ lmsize,yif(1,1,0),lmsize2,czero,mihvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjli(1,1,0), &
+ lmsize,yif(1,1,0),lmsize2,czero,mijvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhli(1,1,0), &
+ lmsize,zif(1,1,0),lmsize2,czero,mihvz,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjli(1,1,0), &
+ lmsize,zif(1,1,0),lmsize2,czero,mijvz,lmsize)
do icheb = 1,ncheb
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
- lmsize,yrf(1,1,icheb,ipan),lmsize2,cone,mrnvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
- lmsize,yrf(1,1,icheb,ipan),lmsize2,cone,mrjvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
- lmsize,zrf(1,1,icheb,ipan),lmsize2,cone,mrnvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
- lmsize,zrf(1,1,icheb,ipan),lmsize2,cone,mrjvz(1,1,ipan),lmsize)
- end do
-! if (idotime==1) call timing_pause('local3')
-
-end do !ipan
-#ifdef CPP_hybrid
-!$NOOMP END DO
-!$NOOMP END PARALLEL
-#endif
-! end the big loop over the subintervals
-
-
-
-!if (idotime==1) call timing_stop('local')
-!if (idotime==1) call timing_start('afterlocal')
-
-! ***********************************************************************
-! calculate A(M), B(M), C(M), D(M)
-! according to 5.17-5.18 (regular solution) of Bauer PhD
-! C,D are calculated accordingly for the irregular solution
-! (starting condition: A(0) = 1, B(0) = 0, C(MMAX) = 0 and D(MMAX) = 1)
-! ***********************************************************************
-
-! regular
-do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- bllp(lm1,lm2,0) = czero
- allp(lm1,lm2,0) = czero
- end do
-end do
-
-do lm1 = 1,lmsize
- allp(lm1,lm1,0) = cone
-end do
-
-do ipan = 1,npan
- call zcopy(lmsize*lmsize,allp(1,1,ipan-1),1,allp(1,1,ipan),1)
- call zcopy(lmsize*lmsize,bllp(1,1,ipan-1),1,bllp(1,1,ipan),1)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvy(1,1,ipan), &
- lmsize,allp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvz(1,1,ipan), &
- lmsize,bllp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvy(1,1,ipan), &
- lmsize,allp(1,1,ipan-1),lmsize,cone,bllp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvz(1,1,ipan), &
- lMSIZE,BLLP(1,1,IPAN-1),LMSIZE,CONE,BLLP(1,1,IPAN),LMSIZE)
-end do
-
-! ***********************************************************************
-! determine the regular solution ull by using 5.14
-! ***********************************************************************
-do ipan = 1,npan
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,yrf(1,1,icheb,ipan), &
- lmsize2,allp(1,1,ipan-1),lmsize,czero,ull(1,1,mn),lmsize2)
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,zrf(1,1,icheb,ipan), &
- lmsize2,bllp(1,1,ipan-1),lmsize,cone,ull(1,1,mn),lmsize2)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhli(1,1,icheb), &
+ lmsize,yif(1,1,icheb),lmsize2,cone,mihvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjli(1,1,icheb), &
+ lmsize,yif(1,1,icheb),lmsize2,cone,mijvy,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhli(1,1,icheb), &
+ lmsize,zif(1,1,icheb),lmsize2,cone,mihvz,lmsize)
+ call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjli(1,1,icheb), &
+ lmsize,zif(1,1,icheb),lmsize2,cone,mijvz,lmsize)
end do
-end do
-
-!if (idotime==1) call timing_stop('afterlocal')
-!if (idotime==1) call timing_start('endstuff')
-
-! ***********************************************************************
-! next part converts the volterra solution u of equation (5.7) to
-! the fredholm solution r by employing eq. 4.122 and 4.120 of bauer, phd
-! and the t-matrix is calculated
-! ***********************************************************************
-
-call zgetrf(lmsize,lmsize,allp(1,1,npan),lmsize,ipiv,info) !invert alpha
-call zgetri(lmsize,allp(1,1,npan),lmsize,ipiv,work,lmsize*lmsize,info) !invert alpha -> transformation matrix rll=alpha^-1*rll
-#ifdef hostcode
-! get alpha matrix
-! DO LM1=1,LMSIZE ! LLY
-! DO LM2=1,LMSIZE ! LLY
-! ALPHAGET(LM1,LM2)=ALLP(LM1,LM2,NPAN) ! LLY
-! ENDDO ! LLY
-! ENDDO ! LLY
-#endif
-! calculation of the t-matrix
-call zgemm('n','n',lmsize,lmsize,lmsize,cone/gmatprefactor,bllp(1,1,npan), & ! calc t-matrix tll = bll*alpha^-1
- lmsize,allp(1,1,npan),lmsize,czero,tllp,lmsize)
-
-do nm = 1,nrmax
-call zgemm('n','n',lmsize2,lmsize,lmsize,cone,ull(1,1,nm), &
- lmsize2,allp(1,1,npan),lmsize,czero,rll(1,1,nm),lmsize2)
-end do
-
-!if (idotime==1) call timing_stop('endstuff')
-!if (idotime==1) call timing_start('checknan')
-!if (idotime==1) call timing_stop('checknan')
-!if (idotime==1) call timing_stop('local1')
-!if (idotime==1) call timing_stop('local2')
-!if (idotime==1) call timing_stop('local3')
-!if (idotime==1) call timing_stop('rll')
-
-if ( use_sratrick==0 ) then
- if(allocated(slv)) deallocate ( slv )
-elseif ( use_sratrick==1 ) then
- if(allocated(work2)) deallocate ( work2, ipiv2 )
- if(allocated(slv1)) deallocate ( slv1 )
-! if(allocated(slv2)) deallocate ( slv2 )
- if(allocated(yrll1)) deallocate ( yrll1, zrll1 )
- if(allocated(yrll2)) deallocate ( yrll2, zrll2 )
-end if
-
-if(allocated(work)) deallocate( work )
-if(allocated(allp)) deallocate( allp, bllp )
-if(allocated(mrnvy)) deallocate( mrnvy, mrnvz )
-if(allocated(mrjvy)) deallocate( mrjvy, mrjvz )
-if(allocated(yrll)) deallocate( yrll, zrll )
-if(allocated(vjlr)) deallocate( vjlr, vhlr )
-if(allocated(vjlr_yrll1)) deallocate( vjlr_yrll1, vhlr_yrll1 )
-if(allocated(vjlr_zrll1)) deallocate( vjlr_zrll1, vhlr_zrll1 )
-if(allocated(yrll1temp)) deallocate( yrll1temp, zrll1temp )
-
-if(allocated(yrf)) deallocate( yrf )
-if(allocated(zrf)) deallocate( zrf )
-
-end subroutine
-
-#ifndef hostcode
-END MODULE MOD_RLL_ONLY
-#endif
-
-#define hostcode ! comment this out to use the impurity code interface
-! choose between interface for impurity and host code (different calling lists)
-#ifndef hostcode
- MODULE MOD_RLLSLL
- CONTAINS
- SUBROUTINE RLLSLL(RPANBOUND,RMESH,VLL,RLL,SLL,TLLP, &
- NCHEB,NPAN,LMSIZE,LMSIZE2,NRMAX, &
- nvec,jlk_index,hlk,jlk,hlk2,jlk2,GMATPREFACTOR, &
- cmoderll,cmodesll,cmodetest,idotime)
-#else
- SUBROUTINE RLLSLL(RPANBOUND,RMESH,VLL,RLL,SLL,TLLP, &
- NCHEB,NPAN,LMSIZE,LMSIZE2,LBESSEL,NRMAX, &
- NVEC,JLK_INDEX,HLK,JLK,HLK2,JLK2,GMATPREFACTOR, &
- CMODERLL,CMODESLL,USE_SRATRICK1) ! &
- ! ALPHAGET) ! LLY
-#endif
-! ************************************************************************
-! radial wave functions by the integral equation method of
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-! which has been extended for KKR using non-sperical potentials.
-! Further information can be found in
-!
-! David Bauer,
-! "Development of a relativistic full-potential first-principles multiple scattering
-! Green function method applied to complex magnetic textures of nano structures
-! at surfaces", PhD Thesis, 2014
-!
-! http://darwin.bth.rwth-aachen.de/opus3/volltexte/2014/4925/
-!
-!
-!
-! ************************************************************************
-! This routine solves the following two equations:
-!
-! ULL(r) = J(r) - PRE * J(r) * int_0^r( dr' r'^2 H2(r') * op(V(r')) * ULL(r') )
-! + PRE * H(r) * int_0^r( dr' r'^2 J2(r') * op(V(r')) * ULL(r') )
-!
-! SLL(r) = H(r) - PRE * H(r) * int_0^r( dr' r'^2 H2(r') * op(V(r')) * RLL(r') )
-! + PRE * J(r) * int_0^r( dr' r'^2 H2(r') * op(V(r')) * SLL(r') )
-!
-! where the integral int_0^r() runs from 0 to r
-! ************************************************************************
-! Potential matrix : VLL(LMSIZE*NVEC,LMSIZE*NVEC)
-! LMSIZE = LMMAX (number of LM components) x Number of spin components
-! LMSIZE2 = NVEC* LMSIZE
-! NVEC is 2 for a spinor and 1 in case of a non-rel. calculation
-!
-! ************************************************************************
-! Green function prefacor PRE=GMATPREFACTOR (scalar value)
-! tipically \kappa for non-relativistic and M_0 \kappa for SRA
-!
-! ************************************************************************
-
-
-! ************************************************************************
-! The discretization of the Lippmann-Schwinger equation results in a matrix
-! equation which is solved in this routine. Further information is given
-! in section 5.2.3, page 90 of Bauer, PhD
-!
-! Source terms :
-! right solution: J, H (nvec*lmsize,lmsize) or (lmsize,nvec*lmsize)
-! left solution: J2,H2 (lmsize,nvec*lmsize) or (nvec*lmsize,lmsize)
-!
-! Example:
-! The source term J is for LMSIZE=3 and NVEC=2 given by:
-! J = / jlk(jlk_index(1)) \
-! | 0 jlk(jlk_index(2)) |
-! | 0 0 jlk(jlk_index(3)) |
-! | jlk(jlk_index(4)) |
-! | 0 jlk(jlk_index(5)) |
-! \ 0 0 jlk(jlk_index(6)) /
-!
-! first 3 rows are for the large and the last 3 rows for the small component
-! ************************************************************************
-! Operator op() can be chosen to be a unity or a transpose operation
-! The unity operation is used to calculate the right solution
-! The transpose operation is used to calculate the left solution
-! ************************************************************************
-! RMESH - radial mesh
-! RPANBOUND - panel bounds RPANBOUND(0) left panel border of panel 1
-! RPANBOUND(1) right panel border of panel 1
-! NCHEB - highes chebyshev polynomial
-! number of points per panel = NCHEB + 1
-! NPAN - number of panels
-! LMSIZE - number of colums for the source matrix J etc...
-! LMSIZE2 - number of rows for the source matrix J etc...
-! NRMAX - total number of radial points (NPAN*(NCHEB+1))
-! NVEC - number of LMSIZE*LMSIZE blocks in J (LMSIZE2=NVEC*LMSIZE)
-! ************************************************************************
-#ifndef hostcode
-use mod_beshank ! calculates bessel and hankel func.
-use mod_chebint ! chebyshev integration routines
-use mod_config, only: config_testflag ! reads if testflags are present
-use mod_physic_params,only: cvlight ! speed of light
-use sourceterms
-use mod_chebyshev
-#endif
-!use mod_timing ! timing routine
-#ifdef CPP_hybrid
-!use omp_lib ! omp functions
-#endif
-implicit none
- integer :: ncheb ! number of chebyshev nodes
- integer :: npan ! number of panels
- integer :: lmsize ! lm-components * nspin
- integer :: lmsize2 ! lmsize * nvec
- integer :: nvec ! spinor integer
- ! nvec=1 non-rel, nvec=2 for sra and dirac
- integer :: nrmax ! total number of rad. mesh points
-#ifdef hostcode
- integer :: LBESSEL, use_sratrick1 ! dimensions etc., needed only for host code interface
-#endif
-
- double complex,parameter:: ci= (0.0d0,1.0d0), &! complex i
- cone=(1.0d0,0.0d0),&! 1
- czero=(0.0d0,0.0d0) ! 0
- ! running indices
- integer ivec, ivec2
- integer l1,l2,lm1,lm2,lm3
- integer info,icheb2,icheb,ipan,mn,nm,nplm
-
- ! source terms
- double complex :: gmatprefactor ! prefactor of green function
- ! non-rel: = kappa = sqrt e
-#ifndef hostcode
- double complex :: hlk(:,:), jlk(:,:), & ! right sol. source terms
- hlk2(:,:), jlk2(:,:) ! left sol. source terms
- ! (tipically bessel and hankel fn)
-#else
- DOUBLE COMPLEX :: HLK(LBESSEL,NRMAX), &
- JLK(LBESSEL,NRMAX), &
- HLK2(LBESSEL,NRMAX), &
- JLK2(LBESSEL,NRMAX)
-#endif
-
-#ifndef hostcode
- integer jlk_index(:) ! mapping array l = jlk_index(lm)
- ! in: lm-index
- ! corresponding l-index used hlk,..
- ! hlk(l) = jlk_index(lm)
-#else
- INTEGER JLK_INDEX(2*LMSIZE)
-#endif
-
- character(len=1) :: cmoderll,cmodesll,cmodetest ! These define the op(V(r)) in the eqs. above
- ! (comment in the beginning of this subroutine)
- ! cmoderll ="1" : op( )=identity for reg. solution
- ! cmoderll ="T" : op( )=transpose in L for reg. solution
- ! cmodesll: same for irregular
- double complex :: sll(lmsize2,lmsize,nrmax), & ! irr. volterra sol.
- rll(lmsize2,lmsize,nrmax), & ! reg. fredholm sol.
- tllp(lmsize,lmsize), & ! t-matrix
- vll(lmsize*nvec,lmsize*nvec,nrmax) ! potential term in 5.7
- ! bauer, phd
- double complex,allocatable :: ull(:,:,:) ! reg. volterra sol.
+end subroutine sll_local_solutions
- double complex,allocatable :: &
- work(:,:), &
- work2(:,:), &
- allp(:,:,:),bllp(:,:,:), & ! eq. 5.9, 5.10 for reg. sol
- cllp(:,:,:),dllp(:,:,:), & ! same for the irr. sol
- slv(:,:,:,:),srv(:,:,:,:), & ! a in eq 5.68
- slv1(:,:,:,:),srv1(:,:,:,:), & !****************
-! slv2(:,:,:,:),srv2(:,:,:,:), & ! used for sra trick
- mrnvy(:,:,:),mrnvz(:,:,:), & ! ***************
- mrjvy(:,:,:),mrjvz(:,:,:), & ! eq. 5.19-5.22
- mihvy(:,:,:),mihvz(:,:,:), & !
- mijvy(:,:,:),mijvz(:,:,:), & ! ***************
- yill(:,:,:),zill(:,:,:), & ! source terms (i:irreg., r: regular)
- yrll(:,:,:),zrll(:,:,:), & !
- yill1(:,:,:),zill1(:,:,:), & ! source terms in case of sratrick
- yrll1(:,:,:),zrll1(:,:,:), &
- yill2(:,:,:),zill2(:,:,:), &
- yrll2(:,:,:),zrll2(:,:,:), &
- vhlr(:,:,:), & ! vhlr = h * v (regular sol.)
- vjlr(:,:,:), & ! vjlr = j * v (regular sol.)
- vhli(:,:,:), & ! vhli = h * v (irregular sol.)
- vjli(:,:,:) ! vjli = j * v (irregular sol.)
- double complex,allocatable :: &
- vhlr_yrll1(:,:), & !
- vhlr_zrll1(:,:), & !
- vjlr_yrll1(:,:), & !
- vjlr_zrll1(:,:), & !
- yrll1temp(:,:), & !
- zrll1temp(:,:), & !
- yill1temp(:,:), & !
- zill1temp(:,:), & !
- vhli_yill1(:,:), & !
- vhli_zill1(:,:), & !
- vjli_yill1(:,:), & !
- vjli_zill1(:,:)
- double complex,allocatable :: yif(:,:,:,:), & ! source terms (different array
- yrf(:,:,:,:), & ! ordering)
- zif(:,:,:,:), &
- zrf(:,:,:,:)
- ! chebyshev arrays
- double complex zslc1sum(0:ncheb)
- double precision c1(0:ncheb,0:ncheb),rpanbound(0:npan)
- double precision cslc1(0:ncheb,0:ncheb), & ! Integration matrix from left ( C*S_L*C^-1 in eq. 5.53)
- csrc1(0:ncheb,0:ncheb), & ! Same from right ( C*S_R*C^-1 in eq. 5.54)
- tau(0:ncheb,0:npan), & ! Radial mesh point
- slc1sum(0:ncheb),rmesh(nrmax),taucslcr,taucsrcr
- integer ipiv(0:ncheb,lmsize2)
- integer,allocatable :: ipiv2(:)
-! logical test
-! integer :: ierror
- integer :: use_sratrick
-! integer :: idotime
- integer,parameter :: directsolv=1
-#ifdef hostcode
-! DOUBLE COMPLEX ALPHAGET(LMSIZE,LMSIZE) ! LLY
-#endif
+SUBROUTINE drvbastrans(rc,crel,rrel,srrel,nrrel,irrel, &
+ nlmax,nkmmax,nmuemax,nkmpmax,nkmax,linmax)
+! ********************************************************************
+! * *
+! * *
+! ********************************************************************
+IMPLICIT REAL*8(a-h,o-z)
-#ifdef CPP_hybrid
-! openMP variable --sacin 23/04/2015
-! integer :: thread_id, number_of_openmp_threads,number_of_processor
-#endif
+COMPLEX*16, INTENT(IN OUT) :: rc(nkmmax,nkmmax)
+COMPLEX*16, INTENT(IN OUT) :: crel(nkmmax,nkmmax)
+COMPLEX*16, INTENT(IN OUT) :: rrel(nkmmax,nkmmax)
+COMPLEX*16, INTENT(IN OUT) :: srrel(2,2,nkmmax)
+INTEGER, INTENT(IN OUT) :: nrrel(2,nkmmax)
+INTEGER, INTENT(IN OUT) :: irrel(2,2,nkmmax)
+INTEGER, INTENT(IN) :: nlmax
+INTEGER, INTENT(IN) :: nkmmax
+INTEGER, INTENT(IN) :: nmuemax
+INTEGER, INTENT(IN) :: nkmpmax
+INTEGER, INTENT(IN) :: nkmax
+INTEGER, INTENT(IN) :: linmax
- external zgetrf,zgetrs
- intrinsic abs,atan,cos,dimag,exp,max,min,sin,sqrt
+!*** Start of declarations rewritten by SPAG
-! ***********************************************************************
-! SRA trick
-! ***********************************************************************
-! on page 68 of Bauer, PhD, a method is described how to speed up the
-! calculations in case of the SRA. A similar approach is implemented
-! here by using Eq. 4.132 and substituting DV from 4.133, and discretising
-! the radial mesh of the Lippmann-Schwinger eq. according to 5.68.
-! The Lippmann-Schwinger equation leads to a matrix inversion
-! problem. The matrix M which needs to be inverted has a special form
-! if the SRA approximation is used:
-!
-! matrix A ( C 0) (same as in eq. 5.68)
-! ( B 1)
-! (C, B are matricies here)
-!
-! inverse of A is (C^-1 0 )
-! (-B C^-1 1 )
-! Thus, it is sufficient to only inverse the matrix C which saves computational
-! time. This is refered to as the SRA trick.
-! ***********************************************************************
-! in future implementation equation 4.134 is supposed to be
-! implemented which should lead to an additional speed-up.
-! ***********************************************************************
+! Local variables
-#ifndef hostcode
-if ( config_testflag('nosph') .or. lmsize==1 ) then
- use_sratrick=0
-elseif ( .not. config_testflag('nosph') ) then
- use_sratrick=1
-else
- stop '[rllsll] use_sratrick error'
-end if
-#else
-if ( lmsize==1 ) then
- use_sratrick=0
-else
- use_sratrick=use_sratrick1
-end if
-#endif
+REAL*8 cgc(nkmpmax,2)
+INTEGER :: i,ikm1lin(linmax),ikm2lin(linmax),il,imue,iprint, &
+ kaptab(nmuemax),ltab(nmuemax),mmax,nmuetab(nmuemax), nsollm(nlmax,nmuemax)
+
+!*** End of declarations rewritten by SPAG
+
+IF (nkmmax /= 2*nlmax**2) STOP ' Check NLMAX,NKMMAX in < DRVBASTRANS > '
+IF (nmuemax /= 2*nlmax) STOP ' Check NLMAX,NMUEMAX in < DRVBASTRANS > '
+IF (nkmpmax /= (nkmmax+2*nlmax)) &
+ STOP ' Check NLMAX,NKMMAX,NKMPMAX in < DRVBASTRANS > '
+IF (nkmax /= 2*nlmax-1) STOP ' Check NLMAX,NKMAX in < DRVBASTRANS > '
+IF (linmax /= (2*nlmax*(2*nlmax-1))) &
+ STOP ' Check NLMAX,LINMAX in < DRVBASTRANS > '
-!#ifdef hostcode
-!! turn timing output off if in the host code
-!idotime = 0
-!#endif
-!if (idotime==1) call timing_start('rllsll')
+iprint = 0
+DO i = 1,nmuemax
+ ltab(i) = i/2
+ IF ( 2*ltab(i) == i ) THEN
+ kaptab(i) = ltab(i)
+ ELSE
+ kaptab(i) = -ltab(i) - 1
+ END IF
+ nmuetab(i) = 2*ABS(kaptab(i))
+END DO
-do ipan = 1,npan
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- tau(icheb,ipan) = rmesh(mn)
- end do
-end do
+DO il = 1,nlmax
+ mmax = 2*il
+ DO imue = 1,mmax
+ IF ( (imue == 1) .OR. (imue == mmax) ) THEN
+ nsollm(il,imue) = 1
+ ELSE
+ nsollm(il,imue) = 2
+ END IF
+ END DO
+END DO
-call chebint(cslc1,csrc1,slc1sum,c1,ncheb)
+CALL ikmlin(iprint,nsollm,ikm1lin,ikm2lin,nlmax,nmuemax,linmax, nlmax)
+CALL calccgc(ltab,kaptab,nmuetab,cgc,nkmax,nmuemax,nkmpmax)
+! ---------------------------- now calculate the transformation matrices
-if(.not.allocated(ull)) allocate ( ull(lmsize2,lmsize,nrmax) )
+CALL strsmat(nlmax-1,cgc,srrel,nrrel,irrel,nkmmax,nkmpmax)
-if ( use_sratrick==0 ) then
- if(.not.allocated(slv)) allocate ( slv(0:ncheb,lmsize2,0:ncheb,lmsize2),srv(0:ncheb,lmsize2,0:ncheb,lmsize2) )
-elseif ( use_sratrick==1 ) then
- if(.not.allocated(work2)) allocate ( work2((ncheb+1)*lmsize,(ncheb+1)*lmsize), ipiv2((ncheb+1)*lmsize) )
- if(.not.allocated(slv1)) allocate ( slv1(0:ncheb,lmsize,0:ncheb,lmsize), srv1(0:ncheb,lmsize,0:ncheb,lmsize) )
-! if(.not.allocated(slv2)) allocate ( slv2(0:ncheb,lmsize,0:ncheb,lmsize), srv2(0:ncheb,lmsize,0:ncheb,lmsize) )
- if(.not.allocated(yill1)) allocate ( yill1(0:ncheb,lmsize,lmsize), zill1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll1)) allocate ( yrll1(0:ncheb,lmsize,lmsize), zrll1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yill2)) allocate ( yill2(0:ncheb,lmsize,lmsize), zill2(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll2)) allocate ( yrll2(0:ncheb,lmsize,lmsize), zrll2(0:ncheb,lmsize,lmsize) )
-else
- stop '[rllsll] error with testflag sph'
-end if
+CALL bastrmat(nlmax-1,cgc,rc,crel,rrel,nkmmax,nkmpmax)
-if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
-if(.not.allocated(allp)) allocate( allp(lmsize,lmsize,0:npan), bllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(cllp)) allocate( cllp(lmsize,lmsize,0:npan), dllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(mrnvy)) allocate( mrnvy(lmsize,lmsize,npan), mrnvz(lmsize,lmsize,npan) )
-if(.not.allocated(mrjvy)) allocate( mrjvy(lmsize,lmsize,npan), mrjvz(lmsize,lmsize,npan) )
-if(.not.allocated(mihvy)) allocate( mihvy(lmsize,lmsize,npan), mihvz(lmsize,lmsize,npan) )
-if(.not.allocated(mijvy)) allocate( mijvy(lmsize,lmsize,npan), mijvz(lmsize,lmsize,npan) )
-if(.not.allocated(yill)) allocate( yill(0:ncheb,lmsize2,lmsize), zill(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(yrll)) allocate( yrll(0:ncheb,lmsize2,lmsize), zrll(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(vjlr)) allocate( vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb) )
-if(.not.allocated(vjli)) allocate( vjli(lmsize,lmsize2,0:ncheb), vhli(lmsize,lmsize2,0:ncheb) )
-if(.not.allocated(vjlr_yrll1)) allocate( vjlr_yrll1(lmsize,lmsize), vhlr_yrll1(lmsize,lmsize) )
-if(.not.allocated(vjlr_zrll1)) allocate( vjlr_zrll1(lmsize,lmsize), vhlr_zrll1(lmsize,lmsize) )
-if(.not.allocated(yrll1temp)) allocate( yrll1temp(lmsize,lmsize), zrll1temp(lmsize,lmsize) )
-if(.not.allocated(vjli_yill1)) allocate( vjli_yill1(lmsize,lmsize), vhli_yill1(lmsize,lmsize) )
-if(.not.allocated(vjli_zill1)) allocate( vjli_zill1(lmsize,lmsize), vhli_zill1(lmsize,lmsize) )
-if(.not.allocated(yill1temp)) allocate( yill1temp(lmsize,lmsize), zill1temp(lmsize,lmsize) )
-
-yrll=(0.0d0,0.0d0)
-zill=(0.0d0,0.0d0)
-yrll=(0.0d0,0.0d0)
-zill=(0.0d0,0.0d0)
+RETURN
+END SUBROUTINE drvbastrans
-if(.not.allocated(yif)) allocate( yif(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(yrf)) allocate( yrf(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zif)) allocate( zif(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zrf)) allocate( zrf(lmsize2,lmsize,0:ncheb,npan) )
+SUBROUTINE changerep(a,mode,b,n,m,rc,crel,rrel,text,ltext)
+! ********************************************************************
+! * *
+! * change the representation of matrix A and store in B *
+! * according to MODE: *
+! * *
+! * RLM>REL non-relat. REAL spher. harm. > (kappa,mue) *
+! * REL>RLM (kappa,mue) > non-relat. REAL spher. harm. *
+! * CLM>REL non-relat. CMPLX. spher. harm. > (kappa,mue) *
+! * REL>CLM (kappa,mue) > non-relat. CMPLX. spher. harm. *
+! * RLM>CLM non-relat. REAL spher. harm. > CMPLX. spher. harm. *
+! * CLM>RLM non-relat. CMPLX. spher. harm. > REAL spher. harm. *
+! * *
+! * the non-relat. representations include the spin index *
+! * *
+! * for LTEXT > 0 the new matrix B is printed *
+! * *
+! ********************************************************************
+IMPLICIT REAL*8(a-h,o-z)
+COMPLEX*16, INTENT(IN OUT) :: a(m,m)
+CHARACTER (LEN=7), INTENT(IN) :: mode
+COMPLEX*16, INTENT(IN OUT) :: b(m,m)
+INTEGER, INTENT(IN OUT) :: n
+INTEGER, INTENT(IN OUT) :: m
+COMPLEX*16, INTENT(IN OUT) :: rc(m,m)
+COMPLEX*16, INTENT(IN OUT) :: crel(m,m)
+COMPLEX*16, INTENT(IN OUT) :: rrel(m,m)
+CHARACTER (LEN=*), INTENT(IN) :: text
+INTEGER, INTENT(IN) :: ltext
-#ifdef CPP_hybrid
-!call omp_set_num_threads(16)
-!number_of_openmp_threads = omp_get_num_threads()
-!write(*,*) 'number_of_openmp_threads: ', number_of_openmp_threads
-!$NOOMP PARALLEL DEFAULT (PRIVATE) &
-!$NOOMP& SHARED(tau,npan,rpanbound,mrnvy,mrnvz,mrjvy,mrjvz,mihvy,mihvz,mijvy,mijvz,yif,yrf, &
-!$NOOMP& zif,zrf,nvec,lmsize,lmsize2,ncheb,jlk,jlk2,jlk_index,vll,gmatprefactor,hlk,hlk2,cslc1,csrc1,slc1sum, &
-!$NOOMP& cmoderll,cmodesll,cmodetest,use_sratrick, rmesh)
+!*** Start of declarations rewritten by SPAG
-!thread_id = omp_get_thread_num()
-#endif
+! PARAMETER definitions
-if(.not.allocated(ull)) allocate ( ull(lmsize2,lmsize,nrmax) )
+COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
+COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
-if ( use_sratrick==0 ) then
- if(.not.allocated(slv)) allocate ( slv(0:ncheb,lmsize2,0:ncheb,lmsize2),srv(0:ncheb,lmsize2,0:ncheb,lmsize2) )
-elseif ( use_sratrick==1 ) then
- if(.not.allocated(work2)) allocate ( work2((ncheb+1)*lmsize,(ncheb+1)*lmsize), ipiv2((ncheb+1)*lmsize) )
- if(.not.allocated(slv1)) allocate ( slv1(0:ncheb,lmsize,0:ncheb,lmsize), srv1(0:ncheb,lmsize,0:ncheb,lmsize) )
-! if(.not.allocated(slv2)) allocate ( slv2(0:ncheb,lmsize,0:ncheb,lmsize), srv2(0:ncheb,lmsize,0:ncheb,lmsize) )
- if(.not.allocated(yill1)) allocate ( yill1(0:ncheb,lmsize,lmsize), zill1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll1)) allocate ( yrll1(0:ncheb,lmsize,lmsize), zrll1(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yill2)) allocate ( yill2(0:ncheb,lmsize,lmsize), zill2(0:ncheb,lmsize,lmsize) )
- if(.not.allocated(yrll2)) allocate ( yrll2(0:ncheb,lmsize,lmsize), zrll2(0:ncheb,lmsize,lmsize) )
-else
- stop '[rllsll] error with testflag sph'
-end if
+! Dummy arguments
-if(.not.allocated(work)) allocate( work(lmsize,lmsize) )
-if(.not.allocated(allp)) allocate( allp(lmsize,lmsize,0:npan), bllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(cllp)) allocate( cllp(lmsize,lmsize,0:npan), dllp(lmsize,lmsize,0:npan) )
-if(.not.allocated(mrnvy)) allocate( mrnvy(lmsize,lmsize,npan), mrnvz(lmsize,lmsize,npan) )
-if(.not.allocated(mrjvy)) allocate( mrjvy(lmsize,lmsize,npan), mrjvz(lmsize,lmsize,npan) )
-if(.not.allocated(mihvy)) allocate( mihvy(lmsize,lmsize,npan), mihvz(lmsize,lmsize,npan) )
-if(.not.allocated(mijvy)) allocate( mijvy(lmsize,lmsize,npan), mijvz(lmsize,lmsize,npan) )
-if(.not.allocated(yill)) allocate( yill(0:ncheb,lmsize2,lmsize), zill(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(yrll)) allocate( yrll(0:ncheb,lmsize2,lmsize), zrll(0:ncheb,lmsize2,lmsize) )
-if(.not.allocated(vjlr)) allocate( vjlr(lmsize,lmsize2,0:ncheb), vhlr(lmsize,lmsize2,0:ncheb) )
-if(.not.allocated(vjli)) allocate( vjli(lmsize,lmsize2,0:ncheb), vhli(lmsize,lmsize2,0:ncheb) )
-yrll=(0.0d0,0.0d0)
-zill=(0.0d0,0.0d0)
-yrll=(0.0d0,0.0d0)
-zill=(0.0d0,0.0d0)
-if(.not.allocated(yif)) allocate( yif(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(yrf)) allocate( yrf(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zif)) allocate( zif(lmsize2,lmsize,0:ncheb,npan) )
-if(.not.allocated(zrf)) allocate( zrf(lmsize2,lmsize,0:ncheb,npan) )
-!if (idotime==1) call timing_start('local')
-! loop over subintervals
-#ifdef CPP_hybrid
-! openMP pragmas added sachin, parallel region starts earlier to get allocations of arrays right
-!$NOOMP DO
-#endif
-do ipan = 1,npan
-! if (idotime==1) call timing_start('local1')
+! Local variables
- ! initialization
-
- vhlr=czero
- vjlr=czero
- vhli=czero
- vjli=czero
+INTEGER :: key
+COMPLEX*16 w1(m,m)
- if (use_sratrick==0) then
+!*** End of declarations rewritten by SPAG
- yrll=czero
- zrll=czero
- yill=czero
- zill=czero
- else
- yrll1=czero
- zrll1=czero
- yill1=czero
- zill1=czero
- yrll2=czero
- zrll2=czero
- yill2=czero
- zill2=czero
- end if
+!---------------------- transform MAT from (kappa,mue) to REAL (l,ml,ms)
+IF ( mode == 'REL>RLM' ) THEN
+ CALL zgemm('N','N',n,n,n,c1,rrel,m,a,m,c0,w1,m)
+ CALL zgemm('N','C',n,n,n,c1,w1,m,rrel,m,c0,b,m)
+ key = 2
+ELSE IF ( mode == 'RLM>REL' ) THEN
+ CALL zgemm('C','N',n,n,n,c1,rrel,m,a,m,c0,w1,m)
+ CALL zgemm('N','N',n,n,n,c1,w1,m,rrel,m,c0,b,m)
+ key = 3
+ELSE IF ( mode == 'REL>CLM' ) THEN
+ CALL zgemm('N','N',n,n,n,c1,crel,m,a,m,c0,w1,m)
+ CALL zgemm('N','C',n,n,n,c1,w1,m,crel,m,c0,b,m)
+ key = 2
+ELSE IF ( mode == 'CLM>REL' ) THEN
+ CALL zgemm('C','N',n,n,n,c1,crel,m,a,m,c0,w1,m)
+ CALL zgemm('N','N',n,n,n,c1,w1,m,crel,m,c0,b,m)
+ key = 3
+ELSE IF ( mode == 'CLM>RLM' ) THEN
+ CALL zgemm('N','N',n,n,n,c1,rc,m,a,m,c0,w1,m)
+ CALL zgemm('N','C',n,n,n,c1,w1,m,rc,m,c0,b,m)
+ key = 2
+ELSE IF ( mode == 'RLM>CLM' ) THEN
+ CALL zgemm('C','N',n,n,n,c1,rc,m,a,m,c0,w1,m)
+ CALL zgemm('N','N',n,n,n,c1,w1,m,rc,m,c0,b,m)
+ key = 2
+ELSE
+ WRITE (*,*) ' MODE = ',mode
+ STOP 'in <ROTATE> MODE not allowed'
+END IF
-!---------------------------------------------------------------------
-! 1. prepare VJLR, VNL, VHLR, which appear in the integrands
-! TAU(K,IPAN) is used instead of TAU(K,IPAN)**2, which directly gives
-! RLL(r) and SLL(r) multiplied with r. TAU is the radial mesh.
-!
-! 2. prepare the source terms YR, ZR, YI, ZI
-! because of the conventions used by
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-! a factor sqrt(E) is included in the source terms
-! this factor is removed by the definition of ZSLC1SUM given below
-!
-!vjlr = \kappa * J * V = \kappa * r * j *V
-!vhlr = \kappa * H * V = \kappa * r * h *V
-!
-! i.e. prepare terms kappa*J*DV, kappa*H*DV appearing in 5.11, 5.12.
+IF ( ltext > 0 ) CALL cmatstr(text,ltext,b,n,m,key,key,0,1D-8,6)
+! IF ( LTEXT.GT.0 ) CALL CMATSTR(TEXT,LTEXT,B,N,M,KEY,KEY,0,1D-12,6)
+END SUBROUTINE changerep
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- if (cmoderll=='1') then
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do
- elseif (cmoderll=='T') then ! transposed matrix (might not be needed anymore)
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vjlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) = vhlr(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do !nvec
- elseif (cmoderll=='0') then ! as a test option
- vjlr(:,:,icheb) = czero
- vhlr(:,:,icheb) = czero
- else
- stop '[rllsll] mode not known'
- end if
+SUBROUTINE bastrmat(lmax,cgc,rc,crel,rrel,nkmmax,nkmpmax)
+! ********************************************************************
+! * *
+! * INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM *
+! * RELATIVISTIC TO REAL SPERICAL HARM. REPRESENTATION *
+! * *
+! * this is a special version of <STRSMAT> passing the *
+! * full BASis TRansformation MATrices RC, CREL and RREL *
+! * *
+! * 13/01/98 HE *
+! ********************************************************************
- if (cmodesll=='1') then
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjli(lm1,lm2+lmsize*(ivec2-1),icheb) = vjli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- vhli(lm1,lm2+lmsize*(ivec2-1),icheb) = vhli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm1+lmsize*(ivec-1),lm2+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do !nvec
- elseif (cmodesll=='T') then
- do ivec2=1,nvec
- do lm2 = 1,lmsize
- do ivec=1,nvec
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- vjli(lm1,lm2+lmsize*(ivec2-1),icheb) = vjli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*jlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- vhli(lm1,lm2+lmsize*(ivec2-1),icheb) = vhli(lm1,lm2+lmsize*(ivec2-1),icheb) + &
- gmatprefactor*tau(icheb,ipan)*hlk2(l1,mn)*vll(lm2+lmsize*(ivec-1),lm1+lmsize*(ivec2-1),mn)
- end do
- end do
- end do
- end do !nvec
- elseif (cmodesll=='0') then
- vjli(:,:,icheb) = czero
- vhli(:,:,icheb) = czero
- else
- stop '[rllsll] mode not known'
- end if
+IMPLICIT REAL*8(a-h,o-z)
- ! calculation of the J (and H) matrix according to equation 5.69 (2nd eq.)
- if ( use_sratrick==0 ) then
- do ivec=1,nvec ! index for large/small component
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(ivec-1) )
- yrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- zrll(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- yill(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- zill(icheb,lm1+lmsize*(ivec-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- end do
- end do !ivec=1,nvec
- elseif ( use_sratrick==1 ) then
- do lm1 = 1,lmsize
- l1 = jlk_index( lm1+lmsize*(1-1) )
- l2 = jlk_index( lm1+lmsize*(2-1) )
- yrll1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- zrll1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- yill1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l1,mn)
- zill1(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l1,mn)
- yrll2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l2,mn)
- zrll2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l2,mn)
- yill2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*hlk(l2,mn)
- zill2(icheb,lm1+lmsize*(1-1),lm1) = tau(icheb,ipan)*jlk(l2,mn)
- end do
- end if
- end do ! icheb
+INTEGER, INTENT(IN) :: lmax
+REAL*8, INTENT(IN) :: cgc(nkmpmax,2)
+COMPLEX*16, INTENT(OUT) :: rc(nkmmax,nkmmax)
+COMPLEX*16, INTENT(OUT) :: crel(nkmmax,nkmmax)
+COMPLEX*16, INTENT(IN OUT) :: rrel(nkmmax,nkmmax)
+INTEGER, INTENT(IN) :: nkmmax
+INTEGER, INTENT(IN) :: nkmpmax
- ! calculation of A in 5.68
- if ( use_sratrick==0 ) then
- do icheb2 = 0,ncheb
- do icheb = 0,ncheb
- taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
- taucsrcr = tau(icheb,ipan)*csrc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0
- mn = ipan*ncheb + ipan - icheb
- do lm2 = 1,lmsize2
- do ivec=1,nvec
- do lm3 = 1,lmsize
- lm1=lm3+(ivec-1)*lmsize
- l1 = jlk_index(lm1)
- slv(icheb,lm1,icheb2,lm2) = &
- taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
- -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
- srv(icheb,lm1,icheb2,lm2) = &
- taucsrcr*(-jlk(l1,mn)*vhli(lm3,lm2,icheb2) &
- +hlk(l1,mn)*vjli(lm3,lm2,icheb2))
-! slv(icheb,lm1,icheb2,lm2) = &
-! ( tau(icheb,ipan)*jlk(l1,mn)*cslc1(icheb,icheb2)*vhlr(lm3,lm2,icheb2) &
-! -tau(icheb,ipan)*hlk(l1,mn)*cslc1(icheb,icheb2)*vjlr(lm3,lm2,icheb2))&
-! *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
-! srv(icheb,lm1,icheb2,lm2) = &
-! (-tau(icheb,ipan)*jlk(l1,mn)*csrc1(icheb,icheb2)*vhli(lm3,lm2,icheb2) &
-! +tau(icheb,ipan)*hlk(l1,mn)*csrc1(icheb,icheb2)*vjli(lm3,lm2,icheb2)) &
-! *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0
- end do
- end do
- end do
- end do
- end do
- do lm1 = 1,lmsize2
- do icheb = 0,ncheb
- slv(icheb,lm1,icheb,lm1) = slv(icheb,lm1,icheb,lm1) + 1.d0
- srv(icheb,lm1,icheb,lm1) = srv(icheb,lm1,icheb,lm1) + 1.d0
- end do
- end do
- elseif ( use_sratrick==1 ) then
- do icheb2 = 0,ncheb
- do icheb = 0,ncheb
- taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
- taucsrcr = tau(icheb,ipan)*csrc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0
- mn = ipan*ncheb + ipan - icheb
- do lm2 = 1,lmsize
-! do ivec=1,1
- do lm3 = 1,lmsize
-! lm1=lm3+(ivec-1)*lmsize
- lm1=lm3
- l1 = jlk_index(lm1)
+!*** Start of declarations rewritten by SPAG
- ! this is the block to be inverted in SRAtrick. (named C in comment above):
- slv1(icheb,lm1,icheb2,lm2) = &
- taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
- -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
- srv1(icheb,lm1,icheb2,lm2) = &
- taucsrcr*(-jlk(l1,mn)*vhli(lm3,lm2,icheb2) &
- +hlk(l1,mn)*vjli(lm3,lm2,icheb2))
+! PARAMETER definitions
- end do
-! end do
- end do
- end do
- end do
-! do icheb2 = 0,ncheb
-! do icheb = 0,ncheb
-! taucslcr = tau(icheb,ipan)*cslc1(icheb,icheb2) &
-! *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
-! taucsrcr = tau(icheb,ipan)*csrc1(icheb,icheb2) &
-! *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0
-! mn = ipan*ncheb + ipan - icheb
-! do lm2 = 1,lmsize
-! do ivec=2,2
-! do lm3 = 1,lmsize
-! lm1=lm3+(ivec-1)*lmsize
-! lm1=lm3+lmsize
-! l1 = jlk_index(lm1)
-
-! slv2(icheb,lm3,icheb2,lm2) = &
-! taucslcr*(jlk(l1,mn)*vhlr(lm3,lm2,icheb2) &
-! -hlk(l1,mn)*vjlr(lm3,lm2,icheb2))
-! srv2(icheb,lm3,icheb2,lm2) = &
-! taucsrcr*(-jlk(l1,mn)*vhli(lm3,lm2,icheb2) &
-! +hlk(l1,mn)*vjli(lm3,lm2,icheb2))
-
-! end do
-! end do
-! end do
-! end do
-! end do
- do lm1 = 1,lmsize
- do icheb = 0,ncheb
- slv1(icheb,lm1,icheb,lm1) = slv1(icheb,lm1,icheb,lm1) + 1.d0
- srv1(icheb,lm1,icheb,lm1) = srv1(icheb,lm1,icheb,lm1) + 1.d0
- end do
- end do
+COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
+COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
+COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
- else
- stop '[rllsll] error in inversion'
- end if
+! Local variables
-! if (idotime==1) call timing_pause('local1')
-! if (idotime==1) call timing_start('local2')
+INTEGER :: i,ikm,j,jp05,k,l,lm,lnr,m,muem05,muep05,nk,nkm,nlm
+REAL*8 w
-!-------------------------------------------------------
-! determine the local solutions
-! solve the equations SLV*YRLL=S and SLV*ZRLL=C
-! and SRV*YILL=C and SRV*ZILL=S
-! i.e., solve system A*U=J, see eq. 5.68.
+!*** End of declarations rewritten by SPAG
- if ( use_sratrick==0 ) then
- nplm = (ncheb+1)*lmsize2
+nk = 2*(lmax+1) + 1
+nlm = (lmax+1)**2
+nkm = 2*nlm
+! ===================================================
+! INDEXING:
+! IKM = L*2*(J+1/2) + J + MUE + 1
+! LM = L*(L+1) + M + 1
+! ===================================================
- if (cmoderll/='0') then
-! if (idotime==1) call timing_start('inversion')
- call zgetrf(nplm,nplm,slv,nplm,ipiv,info)
-! if (idotime==1) call timing_stop('inversion','test')
- if (info/=0) stop 'rllsll: zgetrf'
- call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,yrll,nplm,info)
- call zgetrs('n',nplm,lmsize,slv,nplm,ipiv,zrll,nplm,info)
- end if
- if (cmodesll/='0') then
-! if (directsolv==1) then
- call zgetrf(nplm,nplm,srv,nplm,ipiv,info)
- if (info/=0) stop 'rllsll: zgetrf'
- call zgetrs('n',nplm,lmsize,srv,nplm,ipiv,yill,nplm,info)
- call zgetrs('n',nplm,lmsize,srv,nplm,ipiv,zill,nplm,info)
-! else
-! call iterativesol (ncheb,lmsize2,lmsize,srv,yill)
-! call iterativesol (ncheb,lmsize2,lmsize,srv,zill)
-! end if
- end if
- elseif ( use_sratrick==1 ) then
- nplm = (ncheb+1)*lmsize
+! ----------------------------------------------------------------------
+! CREL transforms from COMPLEX (L,M,S) to (KAP,MUE) - representation
+! |LAM> = sum[LC] |LC> * CREL(LC,LAM)
+! ----------------------------------------------------------------------
+CALL cinit(nkmmax*nkmmax,crel)
- call zgetrf(nplm,nplm,slv1,nplm,ipiv,info)
- call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,yrll1,nplm,info)
- call zgetrs('n',nplm,lmsize,slv1,nplm,ipiv,zrll1,nplm,info)
+lm = 0
+DO lnr = 0,lmax
+ DO m = -lnr,lnr
+ lm = lm + 1
+
+ ikm = 0
+ DO k = 1,nk
+ l = k/2
+ IF ( 2*l == k ) THEN
+ jp05 = l
+ ELSE
+ jp05 = l + 1
+ END IF
+
+ DO muem05 = -jp05,(jp05-1)
+ muep05 = muem05 + 1
+ ikm = ikm + 1
+
+ IF ( l == lnr ) THEN
+ IF ( muep05 == m ) crel(lm,ikm) = cgc(ikm,1)
+ IF ( muem05 == m ) crel(lm+nlm,ikm) = cgc(ikm,2)
+ END IF
+
+ END DO
+ END DO
+
+ END DO
+END DO
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,slv2, &
-! nplm,yrll1,nplm,cone,yrll2,nplm)
+! ----------------------------------------------------------------------
+! RC transforms from REAL to COMPLEX (L,M,S) - representation
+! |LC> = sum[LR] |LR> * RC(LR,LC)
+! ----------------------------------------------------------------------
+CALL cinit(nkmmax*nkmmax,rc)
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,slv2, &
-! nplm,zrll1,nplm,cone,zrll2,nplm)
+w = 1.0D0/SQRT(2.0D0)
- call zgetrf(nplm,nplm,srv1,nplm,ipiv,info)
- call zgetrs('n',nplm,lmsize,srv1,nplm,ipiv,yill1,nplm,info)
- call zgetrs('n',nplm,lmsize,srv1,nplm,ipiv,zill1,nplm,info)
+DO l = 0,lmax
+ DO m = -l,l
+ i = l*(l+1) + m + 1
+ j = l*(l+1) - m + 1
+
+ IF ( m < 0 ) THEN
+ rc(i,i) = -ci*w
+ rc(j,i) = w
+ rc(i+nlm,i+nlm) = -ci*w
+ rc(j+nlm,i+nlm) = w
+ END IF
+ IF ( m == 0 ) THEN
+ rc(i,i) = c1
+ rc(i+nlm,i+nlm) = c1
+ END IF
+ IF ( m > 0 ) THEN
+ rc(i,i) = w*(-1.0D0)**m
+ rc(j,i) = ci*w*(-1.0D0)**m
+ rc(i+nlm,i+nlm) = w*(-1.0D0)**m
+ rc(j+nlm,i+nlm) = ci*w*(-1.0D0)**m
+ END IF
+ END DO
+END DO
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,srv2, &
-! nplm,yill1,nplm,cone,yill2,nplm)
+! ----------------------------------------------------------------------
+! RREL transforms from REAL (L,M,S) to (KAP,MUE) - representation
+! |LAM> = sum[LR] |LR> * RREL(LR,LAM)
+! ----------------------------------------------------------------------
-! call zgemm('n','n',nplm,lmsize,nplm,-cone,srv2, &
-! nplm,zill1,nplm,cone,zill2,nplm)
+CALL zgemm('N','N',nkm,nkm,nkm,c1,rc,nkmmax,crel,nkmmax,c0,rrel, nkmmax)
- do icheb2 = 0,ncheb
- do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- yrll1temp(lm1,lm2) = yrll1(icheb2,lm1,lm2)
- zrll1temp(lm1,lm2) = zrll1(icheb2,lm1,lm2)
- yill1temp(lm1,lm2) = yill1(icheb2,lm1,lm2)
- zill1temp(lm1,lm2) = zill1(icheb2,lm1,lm2)
- end do
- end do
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
- lmsize,yrll1temp,lmsize,czero,vhlr_yrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhlr(1,1,icheb2), &
- lmsize,zrll1temp,lmsize,czero,vhlr_zrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
- lmsize,yrll1temp,lmsize,czero,vjlr_yrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjlr(1,1,icheb2), &
- lmsize,zrll1temp,lmsize,czero,vjlr_zrll1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhli(1,1,icheb2), &
- lmsize,yill1temp,lmsize,czero,vhli_yill1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vhli(1,1,icheb2), &
- lmsize,zill1temp,lmsize,czero,vhli_zill1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjli(1,1,icheb2), &
- lmsize,yill1temp,lmsize,czero,vjli_yill1,lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,cone,vjli(1,1,icheb2), &
- lmsize,zill1temp,lmsize,czero,vjli_zill1,lmsize)
+END SUBROUTINE bastrmat
+
+SUBROUTINE calccgc(ltab,kaptab,nmuetab,cgc,nkmax,nmuemax,nkmpmax)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-01 Time: 12:05:10
+
+! ********************************************************************
+! * *
+! * CLEBSCH-GORDON-COEFFICIENTS CGC(IKM,IS) *
+! * *
+! * IKM NUMBERS CGC FOR INCREASING K AND MUE *
+! * IKM = L*2*(J+1/2) + J + MUE + 1 *
+! * IS= 1/2 SPIN DOWN/UP *
+! * *
+! ********************************************************************
- do icheb = 0,ncheb
- taucslcr = - tau(icheb,ipan)*cslc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0 ! *(b-a)/2 in eq. 5.53, 5.54
- taucsrcr = tau(icheb,ipan)*csrc1(icheb,icheb2) &
- *(rpanbound(ipan)-rpanbound(ipan-1))/ 2.d0
- mn = ipan*ncheb + ipan - icheb
- do lm2 = 1,lmsize
- do lm3 = 1,lmsize
- lm1=lm3+lmsize
- l1 = jlk_index(lm1)
+IMPLICIT NONE
- yrll2(icheb,lm3,lm2) = &
- yrll2(icheb,lm3,lm2) + &
- taucslcr*(jlk(l1,mn)*vhlr_yrll1(lm3,lm2) &
- -hlk(l1,mn)*vjlr_yrll1(lm3,lm2))
+INTEGER, INTENT(IN) :: ltab(nmuemax)
+INTEGER, INTENT(IN) :: kaptab(nmuemax)
+INTEGER, INTENT(IN) :: nmuetab(nmuemax)
+REAL*8, INTENT(OUT) :: cgc(nkmpmax,2)
+INTEGER, INTENT(IN) :: nkmax
+INTEGER, INTENT(IN) :: nmuemax
+INTEGER, INTENT(IN) :: nkmpmax
- zrll2(icheb,lm3,lm2) = &
- zrll2(icheb,lm3,lm2) + &
- taucslcr*(jlk(l1,mn)*vhlr_zrll1(lm3,lm2) &
- -hlk(l1,mn)*vjlr_zrll1(lm3,lm2))
- yill2(icheb,lm3,lm2) = &
- yill2(icheb,lm3,lm2) + &
- taucsrcr*(jlk(l1,mn)*vhli_yill1(lm3,lm2) &
- -hlk(l1,mn)*vjli_yill1(lm3,lm2))
+! Local variables
- zill2(icheb,lm3,lm2) = &
- zill2(icheb,lm3,lm2) + &
- taucsrcr*(jlk(l1,mn)*vhli_zill1(lm3,lm2) &
- -hlk(l1,mn)*vjli_zill1(lm3,lm2))
+INTEGER :: ikm,k,kappa,m
+REAL*8 j,l,mue,twolp1
- end do
- end do
- end do
- end do
+ikm = 0
+DO k = 1,(nkmax+1)
+ l = ltab(k)
+ kappa = kaptab(k)
+ j = ABS(kappa) - 0.5D0
+ mue = -j - 1.0D0
+ twolp1 = 2.0D0*l + 1.0D0
+
+ IF ( kappa < 0 ) THEN
+
+! J = L + 1/2
+ DO m = 1,nmuetab(k)
+
+ mue = mue + 1.0D0
+ ikm = ikm + 1
+ cgc(ikm,1) = DSQRT((l-mue+0.5D0)/twolp1)
+ cgc(ikm,2) = DSQRT((l+mue+0.5D0)/twolp1)
+ END DO
+ ELSE
+! J = L - 1/2
+ DO m = 1,nmuetab(k)
+
+ mue = mue + 1.0D0
+ ikm = ikm + 1
+ cgc(ikm,1) = DSQRT((l+mue+0.5D0)/twolp1)
+ cgc(ikm,2) = -DSQRT((l-mue+0.5D0)/twolp1)
+
+ END DO
+ END IF
+
+
+END DO
- else
- stop '[rllsll] error in inversion'
- end if
+END SUBROUTINE calccgc
- ! Reorient indices for later use
- if ( use_sratrick==0 ) then
- do icheb = 0,ncheb
- do lm2 = 1,lmsize
- do lm1 = 1,lmsize2
- yrf(lm1,lm2,icheb,ipan) = yrll(icheb,lm1,lm2)
- zrf(lm1,lm2,icheb,ipan) = zrll(icheb,lm1,lm2)
- yif(lm1,lm2,icheb,ipan) = yill(icheb,lm1,lm2)
- zif(lm1,lm2,icheb,ipan) = zill(icheb,lm1,lm2)
- end do
- end do
- end do
+!*==cmatstr.f processed by SPAG 6.05Rc at 15:50 on 12 Oct 2002
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-01 Time: 12:05:17
- elseif ( use_sratrick==1 ) then
+SUBROUTINE cmatstr(str,lstr,a,n,m,mlin,mcol,ijq,tolp,k_fmt_fil)
+! ********************************************************************
+! * *
+! * writes structure of COMPLEX NxN matrix A *
+! * *
+! * M is the actual array - size used for A *
+! * MLIN/COL MODE for line and column indexing *
+! * 0: plain, 1: (l,ml), 2: (l,ml,ms), 3: (kap,mue) *
+! * TOL tolerance for difference *
+! * IJQ if IJQ > 1000 pick IQ-JQ-block matrix *
+! * assuming IJQ = IQ*1000 + JQ *
+! * else: no IQ-JQ-indexing *
+! * K_FMT_FIL output channel *
+! * a negative sign suppresses table at the end *
+! * *
+! * any changes should be done in RMATSTR as well !!!!!!!!!!!!!!! *
+! * *
+! ********************************************************************
- do icheb = 0,ncheb
- do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- yrf(lm1,lm2,icheb,ipan) = yrll1(icheb,lm1,lm2)
- zrf(lm1,lm2,icheb,ipan) = zrll1(icheb,lm1,lm2)
- yif(lm1,lm2,icheb,ipan) = yill1(icheb,lm1,lm2)
- zif(lm1,lm2,icheb,ipan) = zill1(icheb,lm1,lm2)
- end do
- end do
- end do
+IMPLICIT COMPLEX*16(a-h,o-z)
- do icheb = 0,ncheb
- do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- yrf(lm1+lmsize,lm2,icheb,ipan) = yrll2(icheb,lm1,lm2)
- zrf(lm1+lmsize,lm2,icheb,ipan) = zrll2(icheb,lm1,lm2)
- yif(lm1+lmsize,lm2,icheb,ipan) = yill2(icheb,lm1,lm2)
- zif(lm1+lmsize,lm2,icheb,ipan) = zill2(icheb,lm1,lm2)
- end do
- end do
- end do
+CHARACTER (LEN=*), INTENT(IN) :: str
+INTEGER, INTENT(IN) :: lstr
+COMPLEX*16, INTENT(IN OUT) :: a(m,m)
+INTEGER, INTENT(IN) :: n
+INTEGER, INTENT(IN) :: m
+INTEGER, INTENT(IN) :: mlin
+INTEGER, INTENT(IN) :: mcol
+INTEGER, INTENT(IN) :: ijq
+REAL*8, INTENT(IN) :: tolp
+INTEGER, INTENT(IN) :: k_fmt_fil
- end if
+!*** Start of declarations rewritten by SPAG
-! if (idotime==1) call timing_pause('local2')
-! if (idotime==1) call timing_start('local3')
+! PARAMETER definitions
- ! Calculation of eq. 5.19-5.22
+COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
- do icheb = 0,ncheb
- zslc1sum(icheb) = slc1sum(icheb) * (rpanbound(ipan)-rpanbound(ipan-1))/ (2.d0)
- end do
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
- lmsize,yrf(1,1,0,ipan),lmsize2,czero,mrnvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
- lmsize,yrf(1,1,0,ipan),lmsize2,czero,mrjvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhlr(1,1,0), &
- lmsize,zrf(1,1,0,ipan),lmsize2,czero,mrnvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjlr(1,1,0), &
- lmsize,zrf(1,1,0,ipan),lmsize2,czero,mrjvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhli(1,1,0), &
- lmsize,yif(1,1,0,ipan),lmsize2,czero,mihvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjli(1,1,0), &
- lmsize,yif(1,1,0,ipan),lmsize2,czero,mijvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vhli(1,1,0), &
- lmsize,zif(1,1,0,ipan),lmsize2,czero,mihvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(0),vjli(1,1,0), &
- lmsize,zif(1,1,0,ipan),lmsize2,czero,mijvz(1,1,ipan),lmsize)
- do icheb = 1,ncheb
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
- lmsize,yrf(1,1,icheb,ipan),lmsize2,cone,mrnvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
- lmsize,yrf(1,1,icheb,ipan),lmsize2,cone,mrjvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhlr(1,1,icheb), &
- lmsize,zrf(1,1,icheb,ipan),lmsize2,cone,mrnvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjlr(1,1,icheb), &
- lmsize,zrf(1,1,icheb,ipan),lmsize2,cone,mrjvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhli(1,1,icheb), &
- lmsize,yif(1,1,icheb,ipan),lmsize2,cone,mihvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjli(1,1,icheb), &
- lmsize,yif(1,1,icheb,ipan),lmsize2,cone,mijvy(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vhli(1,1,icheb), &
- lmsize,zif(1,1,icheb,ipan),lmsize2,cone,mihvz(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize2,zslc1sum(icheb),vjli(1,1,icheb), &
- lmsize,zif(1,1,icheb,ipan),lmsize2,cone,mijvz(1,1,ipan),lmsize)
- end do
-! if (idotime==1) call timing_pause('local3')
+! Local variables
-end do !ipan
-#ifdef CPP_hybrid
-!$NOOMP END DO
-!$NOOMP END PARALLEL
-#endif
-! end the big loop over the subintervals
+COMPLEX*16 b(n,n),ca,cb,arg,dtab(0:n*n)
+CHARACTER (LEN=1) :: CHAR
+LOGICAL :: same,small
+CHARACTER (LEN=1) :: ctab(0:n*n),vz(-1:+1)
+DOUBLE PRECISION :: DBLE
+CHARACTER (LEN=150) :: fmt1,fmt2,fmt3,fmt4
+INTEGER :: i,i1,ic0,id,il,ilsep(20),ipt(218),iq,isl,iw(m),j, &
+ j0,jp,jq,k,l3,lf,mm,n1,n2,n3,nc,nd,nfil,nk,nm,nm1,nm2,nm3, nnon0,nsl
+INTEGER :: ICHAR,ISIGN,nint
+REAL*8 tol
+!*** End of declarations rewritten by SPAG
+DATA vz/'-',' ',' '/
-!if (idotime==1) call timing_stop('local')
-!if (idotime==1) call timing_start('afterlocal')
+small(arg) = ABS(arg*tol) < 1.0D0
-! ***********************************************************************
-! calculate A(M), B(M), C(M), D(M)
-! according to 5.17-5.18 (regular solution) of Bauer PhD
-! C,D are calculated accordingly for the irregular solution
-! (starting condition: A(0) = 1, B(0) = 0, C(MMAX) = 0 and D(MMAX) = 1)
-! ***********************************************************************
+same(ca,cb) = small(1.0D0-ca/cb)
-! regular
-do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- bllp(lm1,lm2,0) = czero
- allp(lm1,lm2,0) = czero
- end do
-end do
+nfil = ABS(k_fmt_fil)
-do lm1 = 1,lmsize
- allp(lm1,lm1,0) = cone
-end do
+tol = 1.0D0/tolp
-do ipan = 1,npan
- call zcopy(lmsize*lmsize,allp(1,1,ipan-1),1,allp(1,1,ipan),1)
- call zcopy(lmsize*lmsize,bllp(1,1,ipan-1),1,bllp(1,1,ipan),1)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvy(1,1,ipan), &
- lmsize,allp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mrnvz(1,1,ipan), &
- lmsize,bllp(1,1,ipan-1),lmsize,cone,allp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvy(1,1,ipan), &
- lmsize,allp(1,1,ipan-1),lmsize,cone,bllp(1,1,ipan),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mrjvz(1,1,ipan), &
- lMSIZE,BLLP(1,1,IPAN-1),LMSIZE,CONE,BLLP(1,1,IPAN),LMSIZE)
-end do
+!----------------------------------------------- set block indices IQ JQ
-! irregular
-do lm2 = 1,lmsize
- do lm1 = 1,lmsize
- dllp(lm1,lm2,npan) = 0.d0
- cllp(lm1,lm2,npan) = 0.d0
- end do
-end do
-do lm1 = 1,lmsize
- dllp(lm1,lm1,npan) = 1.d0
-end do
-do ipan = npan,1,-1
- call zcopy(lmsize*lmsize,cllp(1,1,ipan),1,cllp(1,1,ipan-1),1)
- call zcopy(lmsize*lmsize,dllp(1,1,ipan),1,dllp(1,1,ipan-1),1)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mihvz(1,1,ipan), &
- lmsize,cllp(1,1,ipan),lmsize,cone,cllp(1,1,ipan-1),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize, cone,mihvy(1,1,ipan), &
- lmsize,dllp(1,1,ipan),lmsize,cone,cllp(1,1,ipan-1),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mijvz(1,1,ipan), &
- lmsize,cllp(1,1,ipan),lmsize,cone,dllp(1,1,ipan-1),lmsize)
- call zgemm('n','n',lmsize,lmsize,lmsize,-cone,mijvy(1,1,ipan), &
- lmsize,dllp(1,1,ipan),lmsize,cone,dllp(1,1,ipan-1),lmsize)
-end do
+IF ( ijq > 1000 ) THEN
+ iq = ijq/1000
+ jq = ijq - iq*1000
+ IF ( iq*n > m .OR. iq*n > m ) THEN
+ WRITE (6,99002) ijq,iq,jq,iq*n,jq*n,n,m
+ RETURN
+ END IF
+ELSE
+ iq = 1
+ jq = 1
+END IF
+
+!----------------------------------------------------- copy matrix block
+
+j0 = n*(jq-1)
+DO j = 1,n
+ i1 = n*(iq-1)+1
+ jp = j0 + j
+ CALL zcopy(n,a(i1,jp),1,b(1,j),1)
+END DO
+
+!------------------------------------------------ set up character table
+
+nc = 0
+DO i = 1,26
+ nc = nc + 1
+ ipt(nc) = 62 + i
+END DO
+DO i = 1,8
+ nc = nc + 1
+ ipt(nc) = 96 + i
+END DO
+DO i = 10,26
+ nc = nc + 1
+ ipt(nc) = 96 + i
+END DO
+DO i = 191,218
+ nc = nc + 1
+ ipt(nc) = i
+END DO
+DO i = 35,38
+ nc = nc + 1
+ ipt(nc) = i
+END DO
+DO i = 40,42
+ nc = nc + 1
+ ipt(nc) = i
+END DO
+DO i = 91,93
+ nc = nc + 1
+ ipt(nc) = i
+END DO
-! ***********************************************************************
-! determine the regular solution ull by using 5.14
-! and the irregular solution sll accordingly
-! ***********************************************************************
-do ipan = 1,npan
- do icheb = 0,ncheb
- mn = ipan*ncheb + ipan - icheb
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,yrf(1,1,icheb,ipan), &
- lmsize2,allp(1,1,ipan-1),lmsize,czero,ull(1,1,mn),lmsize2)
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,zrf(1,1,icheb,ipan), &
- lmsize2,bllp(1,1,ipan-1),lmsize,cone,ull(1,1,mn),lmsize2)
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,zif(1,1,icheb,ipan), &
- lmsize2,cllp(1,1,ipan),lmsize,czero,sll(1,1,mn),lmsize2)
- call zgemm('n','n',lmsize2,lmsize,lmsize,cone,yif(1,1,icheb,ipan), &
- lmsize2,dllp(1,1,ipan),lmsize,cone,sll(1,1,mn),lmsize2)
- end do
-end do
+!---------------------------------------------------------------- header
+ic0 = ICHAR('0')
+n3 = n/100
+n2 = n/10 - n3*10
+n1 = n - n2*10 - n3*100
-!if (idotime==1) call timing_stop('afterlocal')
-!if (idotime==1) call timing_start('endstuff')
+IF ( n <= 18 ) THEN
+ fmt1 = '(8X,I3,''|'','
+ fmt2 = '( 9X,''--|'','
+ fmt3 = '( 9X,'' #|'','
+ fmt4 = '( 9X,'' |'','
+ELSE
+ fmt1 = '( I4,''|'','
+ fmt2 = '( 2X,''--|'','
+ fmt3 = '( 2X,'' #|'','
+ fmt4 = '( 2X,'' |'','
+END IF
-! ***********************************************************************
-! next part converts the volterra solution u of equation (5.7) to
-! the fredholm solution r by employing eq. 4.122 and 4.120 of bauer, phd
-! and the t-matrix is calculated
-! ***********************************************************************
+lf = 11
+l3 = 11
+IF ( mcol == 0 ) THEN
+ fmt1 = fmt1(1:lf)//CHAR(ic0+n3)//CHAR(ic0+n2)//CHAR(ic0+n1) &
+ //'( 2A1),''|'',I3)'
+ fmt2 = fmt2(1:lf)//CHAR(ic0+n3)//CHAR(ic0+n2)//CHAR(ic0+n1) &
+ //'(''--''),''|'',I3)'
+ fmt3 = fmt3(1:lf)//'60(2X,I2))'
+ fmt4 = fmt4(1:lf)//'60(I2,2X))'
+ lf = 21
+ELSE
+ IF ( mcol == 1 ) THEN
+ nk = nint(SQRT(DBLE(n)))
+ ELSE IF ( mcol == 2 ) THEN
+ nk = nint(SQRT(DBLE(n/2)))
+ ELSE IF ( mcol == 3 ) THEN
+ nk = 2*nint(SQRT(DBLE(n/2))) - 1
+ END IF
+ DO k = 1,nk
+ IF ( mcol <= 2 ) THEN
+ nm = 2*k - 1
+ ELSE
+ nm = 2*((k+1)/2)
+ END IF
+ nm2 = nm/10
+ nm1 = nm - nm2*10
+ nm3 = nm/2
+ fmt1 = fmt1(1:lf)//CHAR(ic0+nm2)//CHAR(ic0+nm1) //'( 2A1),''|'','
+ fmt2 = fmt2(1:lf)//CHAR(ic0+nm2)//CHAR(ic0+nm1) //'(''--''),''|'','
+
+ IF ( mcol <= 2 ) THEN
+ DO mm = 1,nm
+ IF ( MOD(mm,2) == MOD(k,2) ) THEN
+ fmt3 = fmt3(1:l3)//'2X,'
+ fmt4 = fmt4(1:l3)//'I2,'
+ ELSE
+ fmt3 = fmt3(1:l3)//'I2,'
+ fmt4 = fmt4(1:l3)//'2X,'
+ END IF
+ l3 = l3 + 3
+ END DO
+ fmt3 = fmt3(1:l3)//'''|'','
+ fmt4 = fmt4(1:l3)//'''|'','
+ l3 = l3 + 4
+ ELSE
+ fmt3 = fmt3(1:lf)//CHAR(ic0+nm3)//'(2X,I2),''|'','
+ fmt4 = fmt4(1:lf)//CHAR(ic0+nm3)//'(I2,2X),''|'','
+ l3 = l3 + 13
+ END IF
+ lf = lf + 13
+ END DO
+ IF ( mcol == 2 ) THEN
+ fmt1 = fmt1(1:lf)//fmt1(12:lf)
+ fmt2 = fmt2(1:lf)//fmt2(12:lf)
+ fmt3 = fmt3(1:l3)//fmt3(12:l3)
+ fmt4 = fmt4(1:l3)//fmt4(12:l3)
+ lf = 2*lf - 11
+ l3 = 2*l3 - 11
+ END IF
+ fmt1 = fmt1(1:lf)//'I3)'
+ fmt2 = fmt2(1:lf)//'I3)'
+ fmt3 = fmt3(1:l3)//'I3)'
+ fmt4 = fmt4(1:l3)//'I3)'
+END IF
+IF ( mlin == 0 ) THEN
+ nsl = 1
+ ilsep(1) = n
+ELSE IF ( mlin == 1 ) THEN
+ nsl = nint(SQRT(DBLE(n)))
+ DO il = 1,nsl
+ ilsep(il) = il**2
+ END DO
+ELSE IF ( mlin == 2 ) THEN
+ nsl = nint(SQRT(DBLE(n/2)))
+ DO il = 1,nsl
+ ilsep(il) = il**2
+ END DO
+ DO il = 1,nsl
+ ilsep(nsl+il) = ilsep(nsl) + il**2
+ END DO
+ nsl = 2*nsl
+ELSE IF ( mlin == 3 ) THEN
+ nsl = 2*nint(SQRT(DBLE(n/2))) - 1
+ ilsep(1) = 2
+ DO k = 2,nsl
+ ilsep(k) = ilsep(k-1) + 2*((k+1)/2)
+ END DO
+END IF
-call zgetrf(lmsize,lmsize,allp(1,1,npan),lmsize,ipiv,info) !invert alpha
-call zgetri(lmsize,allp(1,1,npan),lmsize,ipiv,work,lmsize*lmsize,info) !invert alpha -> transformation matrix rll=alpha^-1*rll
-#ifdef hostcode
-! get alpha matrix
-! DO LM1=1,LMSIZE ! LLY
-! DO LM2=1,LMSIZE ! LLY
-! ALPHAGET(LM1,LM2)=ALLP(LM1,LM2,NPAN) ! LLY
-! ENDDO ! LLY
-! ENDDO ! LLY
-#endif
-! calculation of the t-matrix
-call zgemm('n','n',lmsize,lmsize,lmsize,cone/gmatprefactor,bllp(1,1,npan), & ! calc t-matrix tll = bll*alpha^-1
- lmsize,allp(1,1,npan),lmsize,czero,tllp,lmsize)
-do nm = 1,nrmax
-call zgemm('n','n',lmsize2,lmsize,lmsize,cone,ull(1,1,nm), &
- lmsize2,allp(1,1,npan),lmsize,czero,rll(1,1,nm),lmsize2)
-end do
+WRITE (nfil,99001) str(1:lstr)
+IF ( ijq > 1000 ) WRITE (nfil,99003) iq,jq
+WRITE (nfil,fmt3) (i,i=2,n,2)
+WRITE (nfil,fmt4) (i,i=1,n,2)
+WRITE (nfil,FMT=fmt2)
+!------------------------------------------------------------ header end
+nnon0 = 0
+nd = 0
+ctab(0) = ' '
+dtab(0) = 9999D0
-!if (idotime==1) call timing_stop('endstuff')
-!if (idotime==1) call timing_start('checknan')
-!if (idotime==1) call timing_stop('checknan')
-!if (idotime==1) call timing_stop('local1')
-!if (idotime==1) call timing_stop('local2')
-!if (idotime==1) call timing_stop('local3')
-!if (idotime==1) call timing_stop('rllsll')
-
-if ( use_sratrick==0 ) then
- if(allocated(slv)) deallocate ( slv,srv )
-elseif ( use_sratrick==1 ) then
- if(allocated(work2)) deallocate ( work2, ipiv2 )
- if(allocated(slv1)) deallocate ( slv1, srv1 )
-! if(allocated(slv2)) deallocate ( slv2, srv2 )
- if(allocated(yill1)) deallocate ( yill1, zill1 )
- if(allocated(yrll1)) deallocate ( yrll1, zrll1 )
- if(allocated(yill2)) deallocate ( yill2, zill2 )
- if(allocated(yrll2)) deallocate ( yrll2, zrll2 )
-end if
+DO i = 1,n
+ DO j = 1,n
+ IF ( .NOT.small(b(i,j)) ) THEN
+ nnon0 = nnon0 + 1
+ DO id = 1,nd
+ IF ( same(b(i,j),+dtab(id)) ) THEN
+ iw(j) = +id
+ GO TO 50
+ END IF
+ IF ( same(b(i,j),-dtab(id)) ) THEN
+ iw(j) = -id
+ GO TO 50
+ END IF
+ END DO
+!----------------------------------------------------------- new element
+ nd = nd + 1
+ iw(j) = nd
+ dtab(nd) = b(i,j)
+ IF ( ABS(dtab(nd)-1.0D0)*tol < 1.0D0 ) THEN
+ ctab(nd) = '1'
+ ELSE IF ( ABS(dtab(nd)+1.0D0)*tol < 1.0D0 ) THEN
+ dtab(nd) = +1.0D0
+ ctab(nd) = '1'
+ iw(j) = -nd
+ ELSE IF ( ABS(dtab(nd)-ci)*tol < 1.0D0 ) THEN
+ ctab(nd) = 'i'
+ ELSE IF ( ABS(dtab(nd)+ci)*tol < 1.0D0 ) THEN
+ dtab(nd) = +ci
+ ctab(nd) = 'i'
+ iw(j) = -nd
+ ELSE
+ ctab(nd) = CHAR(ipt(1+MOD((nd+1),nc)))
+ END IF
+ ELSE
+ iw(j) = 0
+ END IF
+ 50 END DO
+!------------------------------------------------------------ write line
+ WRITE (nfil,FMT=fmt1) i, (vz(ISIGN(1,iw(j))),ctab(ABS(iw(j))),j=1, &
+ n),i
+
+ DO isl = 1,nsl
+ IF ( i == ilsep(isl) ) WRITE (nfil,FMT=fmt2)
+ END DO
+END DO
-if(allocated(work)) deallocate( work )
-if(allocated(allp)) deallocate( allp, bllp )
-if(allocated(cllp)) deallocate( cllp, dllp )
-if(allocated(mrnvy)) deallocate( mrnvy, mrnvz )
-if(allocated(mrjvy)) deallocate( mrjvy, mrjvz )
-if(allocated(mihvy)) deallocate( mihvy, mihvz )
-if(allocated(mijvy)) deallocate( mijvy, mijvz )
-if(allocated(yill)) deallocate( yill, zill )
-if(allocated(yrll)) deallocate( yrll, zrll )
-if(allocated(vjlr)) deallocate( vjlr, vhlr )
-if(allocated(vjli)) deallocate( vjli, vhli )
-if(allocated(vjlr_yrll1)) deallocate( vjlr_yrll1, vhlr_yrll1 )
-if(allocated(vjli_yill1)) deallocate( vjli_yill1, vhli_yill1 )
-if(allocated(vjlr_zrll1)) deallocate( vjlr_zrll1, vhlr_zrll1 )
-if(allocated(vjli_zill1)) deallocate( vjli_zill1, vhli_zill1 )
-if(allocated(yrll1temp)) deallocate( yrll1temp, zrll1temp )
-if(allocated(yill1temp)) deallocate( yill1temp, zill1temp )
+!------------------------------------------------------------------ foot
-if(allocated(yif)) deallocate( yif )
-if(allocated(yrf)) deallocate( yrf )
-if(allocated(zif)) deallocate( zif )
-if(allocated(zrf)) deallocate( zrf )
+WRITE (nfil,fmt4) (i,i=1,n,2)
+WRITE (nfil,fmt3) (i,i=2,n,2)
-end subroutine
+IF ( k_fmt_fil > 0 ) THEN
+ WRITE (nfil,99004) (id,ctab(id),dtab(id),id=1,nd)
+ WRITE (nfil,99005) nnon0,tolp,n*n - nnon0,tolp
+ELSE
+ WRITE (nfil,*) ' '
+END IF
+
+99001 FORMAT (/,8X,a,/)
+99002 FORMAT (/,1X,79('*'),/,10X,'inconsistent call of <CMATSTR>',/,10X, &
+ 'argument IJQ =',i8,' implies IQ=',i3,' JQ=',i3,/,10X, &
+ 'IQ*N=',i6,' > M or JQ*N=',i6,' > M for N =',i4, &
+ ' M=',i4,/,1X,79('*'),/)
+99003 FORMAT (8X,'IQ-JQ-block for IQ = ',i3,' JQ = ',i3,/)
+99004 FORMAT (/,8X,'symbols used:',/,(8X,i3,3X,a1,2X,2F20.12))
+99005 FORMAT (/,8X,i5,' elements >',1PE9.1,/, &
+ 8X,i5,' elements <',1PE9.1,/)
+END SUBROUTINE cmatstr
-#ifndef hostcode
-END MODULE MOD_RLLSLL
-#endif
+FUNCTION ikapmue(kappa,muem05)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-01 Time: 12:21:58
-subroutine getCLambdaCinv(Ncheb,CLambdaCinv)
-implicit none
-! set up the Lambda matrix which differentiates the coefficients of an
-! Chebyshev expansion
-integer :: Ncheb
-double precision :: CLambdaCinv(0:Ncheb,0:Ncheb)
-!local
-double precision :: Lambda(0:Ncheb,0:Ncheb)
-double precision :: Cmatrix(0:Ncheb,0:Ncheb)
-double precision :: Cinvmatrix(0:Ncheb,0:Ncheb)
-double precision :: temp1(0:Ncheb,0:Ncheb)
-integer n
- Lambda=(0.0D0,0.0D0)
- Cmatrix=(0.0D0,0.0D0)
- Cinvmatrix=(0.0D0,0.0D0)
- Lambda=(0.0D0,0.0D0)
- temp1=(0.0D0,0.0D0)
+! ********************************************************************
+! * *
+! * INDEXING OF MATRIX-ELEMENTS: *
+! * *
+! * I = 2*L*(J+1/2) + J + MUE + 1 *
+! * *
+! ********************************************************************
-call getLambda(Ncheb,Lambda)
-call getCinvmatrix(Ncheb,Cinvmatrix)
-call getCmatrix(Ncheb,Cmatrix)
-n=Ncheb+1
- call dgemm('N','N',n,n,n,1d0,Lambda,n,Cinvmatrix,n,0d0,temp1,n)
- call dgemm('N','N',n,n,n,1d0,Cmatrix,n,temp1,n,0d0,CLambdaCinv,n)
-! temp1=matmat_dmdm(Lambda,Cinvmatrix,Ncheb)
-! CLambdaCinv=matmat_dmdm(Cmatrix,temp1,Ncheb)
-end subroutine
+IMPLICIT NONE
-subroutine rotatematrix(mat,theta,phi,lmmax,mode)
-! rotates a matrix in the local frame pointing in
-! the direction of phi and theta to the global frame
-implicit none
-!interface
-double complex,intent(inout) :: mat(2*lmmax,2*lmmax)
-double precision,intent(in) :: phi
-double precision,intent(in) :: theta
-integer :: lmmax
-integer :: mode
-!local
-double complex :: Umat(2*lmmax,2*lmmax)
-double complex :: Udeggamat(2*lmmax,2*lmmax)
-double complex :: mattemp(2*lmmax,2*lmmax)
-!double precision :: matmat_zmzm
+INTEGER, INTENT(IN) :: kappa
+INTEGER, INTENT(IN) :: muem05
-!***********************************************************************
-! create the rotation matrix:
-! | cos(theta/2) exp(-i/2 phi) -sin(theta/2) exp(-i/2 phi) |
-! U= | |
-! | sin(theta/2) exp( i/2 phi) cos(theta/2) exp( i/2 phi) |
-!
-! Udegga = transpose(complex conjug ( U ) )
-!***********************************************************************
+! Dummy arguments
-call create_Umatrix(theta,phi,lmmax,Umat,Udeggamat)
-!***********************************************************************
-! calculate matrix in the global frame:
-!
-! t_glob = U * t_loc * Udegga
-!***********************************************************************
+INTEGER :: ikapmue
-if (mode==0) then ! 'loc->glob'
- call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),mat,2*lmmax,Udeggamat,2*lmmax,(0d0,0d0),mattemp,2*lmmax)
- call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),Umat,2*lmmax,mattemp,2*lmmax,(0d0,0d0),mat,2*lmmax)
-elseif (mode==1) then !'glob->loc'
- call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),mat,2*lmmax,Umat,2*lmmax,(0d0,0d0),mattemp,2*lmmax)
- call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),Udeggamat,2*lmmax,mattemp,2*lmmax,(0d0,0d0),mat,2*lmmax)
-else
- stop '[rotatematrix] mode not known'
-end if
-! writE(324,'(5000F)') tmat
-! stop
+! Local variables
-end subroutine rotatematrix
+INTEGER :: IABS
+INTEGER :: jp05,l
+jp05 = IABS(kappa)
-SUBROUTINE spin_orbit_compl(lmax,lmmaxd,l_s)
+IF ( kappa < 0 ) THEN
+ l = -kappa - 1
+ELSE
+ l = kappa
+END IF
+
+ikapmue = 2*l*jp05 + jp05 + muem05 + 1
+
+END FUNCTION ikapmue
+
+
+SUBROUTINE ikmlin(iprint,nsollm,ikm1lin,ikm2lin,nlmax,nmuemax, &
+ linmax,nl)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-01 Time: 12:05:20
+
+! ********************************************************************
+! * *
+! * SETUP TABLE OF INDICES IKM(INT) *
+! * *
+! * IKM IS STANDARD INDEX IN (KAPPA,MUE)-REPRESENTATION *
+! * IKM = 2*L*(J+1/2) + J + MUE + 1 *
+! * *
+! * INT NUMBERS LINEARLY ONLY NON-VANISHING ELEMENTS OF M-SS *
+! * USED TO CALCULATE DOS ... *
+! * *
+! ********************************************************************
IMPLICIT NONE
-INTEGER, INTENT(IN) :: lmax
-INTEGER, INTENT(IN) :: lmmaxd
-DOUBLE COMPLEX, INTENT(OUT):: l_s(:,:)
-! ************************************************************************
-! in this subroutine the matrix L*S is calculated for the basis of
-! real spherical harmonics
+INTEGER, INTENT(IN) :: iprint
+INTEGER, INTENT(IN) :: nsollm(nlmax,nmuemax)
+INTEGER, INTENT(OUT) :: ikm1lin(linmax)
+INTEGER, INTENT(OUT) :: ikm2lin(linmax)
+INTEGER, INTENT(IN) :: nlmax
+INTEGER, INTENT(IN) :: nmuemax
+INTEGER, INTENT(IN) :: linmax
+INTEGER, INTENT(IN) :: nl
-! local variableINTEGER :: i1,i2,i1l,rl,lm1,lm2
-INTEGER :: rl,lm1,lm2
-DOUBLE COMPLEX,allocatable :: ls_l(:,:)
+! Dummy arguments
-!icompl=(0D0,1D0)
-CALL cinit((2*lmmaxd)**2,l_s)
+! Local variables
-DO rl=0,lmax
-
- allocate(ls_l((2*rl+1)*2,(2*rl+1)*2))
- CALL cinit(((2*rl+1)*2)**2,ls_l)
-
-
- CALL spin_orbit_one_l(rl,ls_l)
+INTEGER :: i,il,imue,k1,k2,kap(2),l,lin,muem05,nsol
+!INTEGER :: ikapmue
+
+lin = 0
+
+DO il = 1,nl
+ l = il - 1
+ muem05 = -il - 1
+ kap(1) = -l - 1
+ kap(2) = +l
- DO lm1=1,(2*rl+1)*2
+ DO imue = 1,2*il
+ muem05 = muem05 + 1
+ nsol = nsollm(il,imue)
- IF (lm1 <= 2*rl+1 ) THEN
- DO lm2=1,(2*rl+1)
- l_s(rl**2+lm1,rl**2+lm2)=0.5D0*ls_l(lm1,lm2)
- END DO
- DO lm2=(2*rl+1)+1,(2*rl+1)*2
- l_s(rl**2+lm1,lmmaxd+rl**2-(2*rl+1)+lm2)= 0.5D0*ls_l(lm1,lm2)
- END DO
- ELSE
- DO lm2=1,(2*rl+1)
- l_s(lmmaxd+rl**2-(2*rl+1)+lm1,rl**2+lm2)= 0.5D0*ls_l(lm1,lm2)
- END DO
- DO lm2=(2*rl+1)+1,(2*rl+1)*2
- l_s(lmmaxd+rl**2-(2*rl+1)+lm1,lmmaxd+rl**2-(2*rl+1)+lm2)= &
- 0.5D0*ls_l(lm1,lm2)
+ DO k2 = 1,nsol
+ DO k1 = 1,nsol
+ lin = lin + 1
+ ikm1lin(lin) = ikapmue(kap(k1),muem05)
+ ikm2lin(lin) = ikapmue(kap(k2),muem05)
END DO
- END IF
+ END DO
- END DO !lm1
-
- deallocate(ls_l)
-
-
-END DO !rl=0,lmax
-
-
-END SUBROUTINE spin_orbit_compl
+ END DO
+END DO
+IF ( iprint < 2 ) RETURN
+WRITE (6,FMT='('' INT='',I3,'' IKM=('',I3,'','',I3,'')'')') &
+ (i,ikm1lin(i),ikm2lin(i),i=1,lin)
+END SUBROUTINE ikmlin
-SUBROUTINE beshank(hl,jl,z,lmax)
+SUBROUTINE strsmat(lmax,cgc,srrel,nrrel,irrel,nkmmax,nkmpmax)
! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-19 Time: 12:22:05
+! Date: 2016-04-01 Time: 12:05:34
-!-----------------------------------------------------------------------
-! calculates spherical bessel, hankel and neumann functions
-! for the orders lmin .le. l .le. lmax.
-! For |z| .lt. l+1 the taylor expansions of jl and nl are used.
-! For |z| .ge. l+1 the explicit expressions for hl(+), hl(-) are used.
-!-----------------------------------------------------------------------
-! .. Parameters ..
-DOUBLE COMPLEX ci
-PARAMETER (ci= (0.0D0,1.0D0))
-! ..
-! .. Scalar Arguments ..
-DOUBLE COMPLEX z
-INTEGER :: lmax
-! ..
-! .. Array Arguments ..
-DOUBLE COMPLEX hl(0:lmax),jl(0:lmax),nl(0:lmax)
-! ..
-! .. Local Scalars ..
-DOUBLE COMPLEX termj,termn,z2,zj,zn
-DOUBLE PRECISION :: rl,rn,rnm
-INTEGER :: l,m,n
-! ..
-! .. Intrinsic Functions ..
-INTRINSIC CDABS,EXP
-! ..
-zj = 1.d0
-zn = 1.d0
-z2 = z*z
-IF (CDABS(z) < lmax+1.d0) THEN
- DO l = 0,lmax
- rl = l + l
- termj = -0.5D0/ (rl+3.d0)*z2
- termn = 0.5D0/ (rl-1.d0)*z2
- jl(l) = 1.d0
- nl(l) = 1.d0
- DO n = 2,25
- jl(l) = jl(l) + termj
- nl(l) = nl(l) + termn
- rn = n + n
- termj = -termj/ (rl+rn+1.d0)/rn*z2
- termn = termn/ (rl-rn+1.d0)/rn*z2
- END DO
- jl(l) = jl(l)*zj
- nl(l) = -nl(l)*zn/z
- hl(l) = jl(l) + nl(l)*ci
-
- zj = zj*z/ (rl+3.d0)
- zn = zn/z* (rl+1.d0)
- END DO
-END IF
+! ********************************************************************
+! * *
+! * INITIALIZE TRANSFORMATION MATRIX THAT TAKES MATRICES FROM *
+! * RELATIVISTIC TO REAL SPERICAL HARM. REPRESENTATION *
+! * *
+! * ONLY THE NON-0 ELEMENTS OF THE MATRIX ARE STORED *
+! * *
+! * 25/10/95 HE proper convention of trans. matrix introduced *
+! ********************************************************************
-DO l = 0,lmax
- IF (CDABS(z) >= l+1.d0) THEN
- hl(l) = 0.d0
- nl(l) = 0.d0
- rnm = 1.d0
- DO m = 0,l
- hl(l) = hl(l) + rnm/ (-ci* (z+z))**m
- nl(l) = nl(l) + rnm/ (ci* (z+z))**m
- rnm = rnm* (l*l+l-m*m-m)/ (m+1.d0)
- END DO
- hl(l) = hl(l)* (-ci)**l*EXP(ci*z)/ (ci*z)
- nl(l) = nl(l)*ci**l*EXP(-ci*z)/ (-ci*z)
- jl(l) = (hl(l)+nl(l))*0.5D0
- nl(l) = (hl(l)-jl(l))/ci
- END IF
-END DO
+IMPLICIT NONE
-RETURN
+INTEGER, INTENT(IN) :: lmax
+REAL*8, INTENT(IN) :: cgc(nkmpmax,2)
+COMPLEX*16, INTENT(OUT) :: srrel(2,2,nkmmax)
+INTEGER, INTENT(OUT) :: nrrel(2,nkmmax)
+INTEGER, INTENT(OUT) :: irrel(2,2,nkmmax)
+INTEGER, INTENT(IN) :: nkmmax
+INTEGER, INTENT(IN) :: nkmpmax
+
+! PARAMETER definitions
-END SUBROUTINE
+COMPLEX*16, PARAMETER :: ci=(0.0D0,1.0D0)
+COMPLEX*16, PARAMETER :: c1=(1.0D0,0.0D0)
+COMPLEX*16, PARAMETER :: c0=(0.0D0,0.0D0)
-SUBROUTINE beshank_smallcomp(hl,jl,zval,tau,eryd,lmax)
-IMPLICIT NONE
-!-----------------------------------------------------------------------
-! takes the spherical bessel etc functions stored in an array up to LMAX
-! array entries from LMAX+1 to 2*LMAX are assumed to be empty
-! these values are filled with the potential-free solution of the
-! SRA-equations
-!-----------------------------------------------------------------------
-DOUBLE COMPLEX hl(0:2*(lmax+1)-1), jl(0:2*(lmax+1)-1), &
- nl(0:2*(lmax+1)-1)
-DOUBLE PRECISION :: cvlight
-PARAMETER (cvlight=274.0720442D0)
-DOUBLE COMPLEX zval
-DOUBLE COMPLEX eryd
-DOUBLE PRECISION :: tau
-INTEGER :: lmax
+! Dummy arguments
-! DOUBLE PRECISION CVLIGHT
-DOUBLE COMPLEX prefac
-INTEGER :: il,il2
-prefac = 1.0D0 / (1.0D0+eryd/cvlight**2) / tau !/cvlight !last cvlight for small component test
-il=0
-il2=il+lmax+1
-nl(il2)=prefac * (zval* (-nl(il+1)) )
-jl(il2)=prefac * (zval* (-jl(il+1)) )
-! HL(IL2)=JL(IL2)+ CI*NL(IL2)
-hl(il2)=prefac * (zval* (-hl(il+1)) )
-! write(*,'(5000E)') tau,HL(IL2),JL(IL2)+ (0.0D0,1.0D0)*NL(IL2)
-! write(*,'(5000E)') tau,HL(0),JL(0)+ (0.0D0,1.0D0)*NL(0)
-prefac = 1.0D0 / (1.0D0+eryd/cvlight**2) / tau !/cvlight !last cvlight for small component test
-DO il=1,lmax
- il2=il+lmax+1
- nl(il2)=prefac * ( zval * nl(il-1)-(il+1)*nl(il) )
- jl(il2)=prefac * ( zval * jl(il-1)-(il+1)*jl(il) )
-! HL(IL2)=JL(IL2)+ CI*NL(IL2)
- hl(il2)=prefac * ( zval * hl(il-1)-(il+1)*hl(il) )
-! HL(IL2)=PREFAC * ( ZVAL * HL(IL-1)-(IL+1)*HL(IL) )
-! write(*,'(5000E)') tau,HL(IL2),JL(IL2)+ (0.0D0,1.0D0)*NL(IL2)
-END DO
+! Local variables
-END SUBROUTINE beshank_smallcomp
+COMPLEX*16 crel(nkmmax,nkmmax),rc(nkmmax,nkmmax), rrel(nkmmax,nkmmax)
+INTEGER :: i,ikm,j,jp05,k,l,lam,lm,lnr,lr,m,muem05,muep05,nk,nkm,nlm, ns1,ns2
+REAL*8 w
+nk = 2*(lmax+1) + 1
+nlm = (lmax+1)**2
+nkm = 2*nlm
+! ===================================================
+! INDEXING:
+! IKM = L*2*(J+1/2) + J + MUE + 1
+! LM = L*(L+1) + M + 1
+! ===================================================
-SUBROUTINE chebint(cslc1,csrc1,slc1sum,c1,n)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-19 Time: 14:23:20
-
-!---------------------------------------------------------------------
-! this subroutine calculates the matrices for the Chebyshev integration
-! as defined on page 141 and 142 of the article:
-! Integral Equation Method for the Continuous Spectrum Radial
-! Schroedinger Equation by R. A. Gonzales et al
-! in Journal of computational physics 134, 134-149 (1997)
+! ----------------------------------------------------------------------
+! CREL transforms from COMPLEX (L,M,S) to (KAP,MUE) - representation
+! |LAM> = sum[LC] |LC> * CREL(LC,LAM)
+! ----------------------------------------------------------------------
+CALL cinit(nkmmax*nkmmax,crel)
-! the matrix C is the discrete cosine transform matrix
-! the matrix C1 is the inverse of C
-! the matrix SL is the left spectral integration matrix
-! the matrix SR is the right spectral integration matrix
-! the matrix CSLC1 is the product of C, SL and C1
-! the matrix CSRC1 is the product of C, SR and C1
-!---------------------------------------------------------------------
-! .. Local Scalars ..
-DOUBLE PRECISION :: pi
-INTEGER :: j,k
-! ..
-! .. Local Arrays ..
-DOUBLE PRECISION :: c(0:n,0:n),c1(0:n,0:n),s1(0:n,0:n),s2(0:n,0:n), &
- sl(0:n,0:n),slc1(0:n,0:n),sr(0:n,0:n), src1(0:n,0:n)
-! ..
-! .. External Subroutines ..
-EXTERNAL dgemm
-! ..
-! .. Intrinsic Functions ..
-INTRINSIC ATAN,COS
-! ..
-! .. Array Arguments ..
-DOUBLE PRECISION :: cslc1(0:n,0:n),csrc1(0:n,0:n),slc1sum(0:n)
-! ..
-! .. Scalar Arguments ..
-INTEGER :: n
-! ..
-pi = 4.d0*ATAN(1.d0)
-!---------------------------------------------------------------------
-! determine the discrete cosine transform matrix from the zeros of the
-! Chebyshev polynomials
-DO j = 0,n
- DO k = 0,n
- c(k,j) = COS(((2*k+1)*j*pi)/ (2* (n+1)))
- END DO
-END DO
-!---------------------------------------------------------------------
-! determine the inverse of the discrete cosine transform matrix from
-! the transpose of the discrete cosine transform matrix
-DO j = 0,n
- DO k = 0,n
- c1(k,j) = c(j,k)*2.d0/ (n+1)
- END DO
- c1(0,j) = c1(0,j)*0.5D0
-END DO
-!---------------------------------------------------------------------
-! next to statements can be used to check the products CT*C and C1*C
-CALL dgemm('T','N',n+1,n+1,n+1,1.d0,c,n+1,c,n+1,0.d0,sr,n+1)
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c1,n+1,c,n+1,0.d0,sr,n+1)
-!---------------------------------------------------------------------
-! preparation of the left and right
-! spectral integration matrices SL and SR
-DO j = 0,n
- DO k = 0,n
- s1(k,j) = 0.0D0
- s2(k,j) = 0.0D0
+lm = 0
+DO lnr = 0,lmax
+ DO m = -lnr,lnr
+ lm = lm + 1
+
+ ikm = 0
+ DO k = 1,nk
+ l = k/2
+ IF ( 2*l == k ) THEN
+ jp05 = l
+ ELSE
+ jp05 = l + 1
+ END IF
+
+ DO muem05 = -jp05,(jp05-1)
+ muep05 = muem05 + 1
+ ikm = ikm + 1
+
+ IF ( l == lnr ) THEN
+ IF ( muep05 == m ) crel(lm,ikm) = cgc(ikm,1)
+ IF ( muem05 == m ) crel(lm+nlm,ikm) = cgc(ikm,2)
+ END IF
+
+ END DO
+ END DO
+
END DO
END DO
-DO j = 0,n
- s1(0,j) = (-1.d0)** (j+1)
- s1(j,j) = 1.d0
-END DO
-DO j = 2,n - 1
- s2(j,j-1) = 0.5D0/j
- s2(j,j+1) = -0.5D0/j
-END DO
-s2(n,n-1) = 0.5D0/n
-s2(1,0) = 1.d0
-s2(1,2) = -0.5D0
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,s1,n+1,s2,n+1,0.d0,sl,n+1)
-DO j = 0,n
- DO k = 0,n
- s1(k,j) = 0.0D0
+
+! ----------------------------------------------------------------------
+! RC transforms from REAL to COMPLEX (L,M,S) - representation
+! |LC> = sum[LR] |LR> * RC(LR,LC)
+! ----------------------------------------------------------------------
+CALL cinit(nkmmax*nkmmax,rc)
+
+w = 1.0D0/SQRT(2.0D0)
+
+DO l = 0,lmax
+ DO m = -l,l
+ i = l*(l+1) + m + 1
+ j = l*(l+1) - m + 1
+
+ IF ( m < 0 ) THEN
+ rc(i,i) = -ci*w
+ rc(j,i) = w
+ rc(i+nlm,i+nlm) = -ci*w
+ rc(j+nlm,i+nlm) = w
+ END IF
+ IF ( m == 0 ) THEN
+ rc(i,i) = c1
+ rc(i+nlm,i+nlm) = c1
+ END IF
+ IF ( m > 0 ) THEN
+ rc(i,i) = w*(-1.0D0)**m
+ rc(j,i) = ci*w*(-1.0D0)**m
+ rc(i+nlm,i+nlm) = w*(-1.0D0)**m
+ rc(j+nlm,i+nlm) = ci*w*(-1.0D0)**m
+ END IF
END DO
END DO
-DO j = 0,n
- s1(j,j) = -1.d0
- s1(0,j) = 1.d0
-END DO
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,s1,n+1,s2,n+1,0.d0,sr,n+1)
-!---------------------------------------------------------------------
-! determination of the products C*SL*C1 and C*SR*C1
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,sl,n+1,c1,n+1,0.d0,slc1,n+1)
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c,n+1,slc1,n+1,0.d0,cslc1,n+1)
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,sr,n+1,c1,n+1,0.d0,src1,n+1)
-CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c,n+1,src1,n+1,0.d0,csrc1,n+1)
-!---------------------------------------------------------------------
-DO k = 0,n
- slc1sum(k) = 0.0D0
- DO j = 0,n
- slc1sum(k) = slc1sum(k) + slc1(j,k)
+
+! ----------------------------------------------------------------------
+! RREL transforms from REAL (L,M,S) to (KAP,MUE) - representation
+! |LAM> = sum[LR] |LR> * RREL(LR,LAM)
+! ----------------------------------------------------------------------
+CALL zgemm('N','N',nkm,nkm,nkm,c1,rc,nkmmax,crel,nkmmax,c0,rrel, nkmmax)
+
+! ---------------------------------------------------
+! store the elements of RREL
+! ---------------------------------------------------
+DO lam = 1,nkm
+ ns1 = 0
+ ns2 = 0
+
+ DO lr = 1,2*nlm
+ IF ( CDABS(rrel(lr,lam)) > 1D-6 ) THEN
+ IF ( lr <= nlm ) THEN
+ ns1 = ns1 + 1
+ IF ( ns1 > 2 ) STOP ' IN <STRSMAT> NS1 > 2'
+ srrel(ns1,1,lam) = rrel(lr,lam)
+ irrel(ns1,1,lam) = lr
+ ELSE
+ ns2 = ns2 + 1
+ IF ( ns2 > 2 ) STOP ' IN <STRSMAT> NS2 > 2'
+ srrel(ns2,2,lam) = rrel(lr,lam)
+ irrel(ns2,2,lam) = lr - nlm
+ END IF
+ END IF
END DO
+
+ nrrel(1,lam) = ns1
+ nrrel(2,lam) = ns2
END DO
-RETURN
-END SUBROUTINE
-subroutine getLambda(Ncheb,Lambda)
-! set up the Lambda matrix which differentiates the coefficients of an
-! Chebyshev expansion
-implicit none
-integer :: Ncheb
-double precision :: Lambda(0:Ncheb,0:Ncheb)
-!local
-integer icheb,icheb2
-do icheb2=1,Ncheb,2
- Lambda(0,icheb2)=icheb2
-end do
-do icheb=1,Ncheb
- do icheb2=icheb+1,Ncheb,2
- Lambda(icheb,icheb2)=icheb2*2
- end do
-end do
-end subroutine
+END SUBROUTINE strsmat
+
+SUBROUTINE vllmat(irmin,irc,lmmax,lmmaxso,vnspll0,vins, &
+ cleb,icleb,iend,nspin,z,rnew,use_sratrick)
+! ************************************************************************
+! .. Parameters ..
+IMPLICIT NONE
+
+INTEGER, INTENT(IN) :: irmin
+!INTEGER, INTENT(IN) :: nrmaxd
+INTEGER, INTENT(IN) :: irc
+INTEGER, INTENT(IN) :: lmmax
+INTEGER, INTENT(IN) :: lmmaxso
+DOUBLE COMPLEX, INTENT(OUT) :: vnspll0(:,:,irmin:)
+DOUBLE PRECISION, INTENT(IN OUT) :: vins(irmin:,:,:)
+DOUBLE PRECISION, INTENT(IN) :: cleb(:)
+INTEGER, INTENT(IN) :: icleb(:,:)
+INTEGER, INTENT(IN) :: iend
+INTEGER, INTENT(IN) :: nspin
+DOUBLE PRECISION, INTENT(IN) :: z
+DOUBLE PRECISION, INTENT(IN) :: rnew(irmin:)
+INTEGER, INTENT(IN OUT) :: use_sratrick
+!INCLUDE 'inc.p'
+!INTEGER :: lmpotd
+!DOUBLE PRECISION, INTENT, PARAMETER :: lmpotd= (lpotd+1)**2
+! ..
+! .. Scalar Arguments ..
-subroutine getCinvmatrix(Ncheb,Cinvmatrix)
-! calculates the C**-1 matrix according to:
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-implicit none
-integer, intent(in) :: ncheb
-double precision, intent(out) :: Cinvmatrix(0:Ncheb,0:Ncheb)
-!local
-double precision :: pi
-integer :: icheb1,icheb2
-double precision :: fac
+INTEGER :: isp
+! ..
+! .. Array Arguments ..
+DOUBLE PRECISION, allocatable :: vnspll(:,:,:,:)
-pi=4d0*datan(1d0)
-fac=1.0D0/(Ncheb+1)
-do icheb1=0,ncheb
- do icheb2=0,ncheb
- Cinvmatrix(icheb1,icheb2)=fac*dcos(icheb1*pi*((Ncheb-icheb2)+0.5D0)/(Ncheb+1))
- end do
- fac=2.0D0/(Ncheb+1)
-end do
+! ..
+! .. Local Scalars ..
+INTEGER :: i,ir,j,lm1,lm2,lm3
+! ..
-end subroutine getCinvmatrix
+allocate(vnspll(lmmax,lmmax,irmin:irc,2))
-subroutine getCmatrix(Ncheb,Cmatrix)
-! calculates the C matrix according to:
-! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
-implicit none
-integer, intent(in) :: ncheb
-double precision, intent(out) :: Cmatrix(0:Ncheb,0:Ncheb)
-double precision :: pi
-!local
-integer :: icheb1,icheb2
+DO isp=1,nspin
+ DO lm1 = 1,lmmax
+ DO lm2 = 1,lm1
+ DO ir = irmin,irc
+ vnspll(lm1,lm2,ir,isp) = 0.0D0
+ END DO
+ END DO
+ END DO
+
+ DO j = 1,iend
+ lm1 = icleb(j,1)
+ lm2 = icleb(j,2)
+ lm3 = icleb(j,3)
+ DO i = irmin,irc
+ vnspll(lm1,lm2,i,isp) = vnspll(lm1,lm2,i,isp) + cleb(j)*vins(i,lm3,isp)
+ END DO
+ END DO
+
+!---> use symmetry of the gaunt coef.
+
+ DO lm1 = 1,lmmax
+ DO lm2 = 1,lm1 - 1
+ DO i = irmin,irc
+ vnspll(lm2,lm1,i,isp) = vnspll(lm1,lm2,i,isp)
+ END DO
+ END DO
+ END DO
+
+ IF (use_sratrick == 0) THEN
+ DO lm1=1,lmmax
+ DO i=irmin,irc
+ vnspll(lm1,lm1,i,isp)=vnspll(lm1,lm1,i,isp)+ &
+ vins(i,1,isp)-2D0*z/rnew(i)
+ END DO
+ END DO
+ END IF
+
+END DO !NSPIN
-pi=4d0*datan(1d0)
-do icheb1=0,ncheb
- do icheb2=0,ncheb
- ! maybe incorrect
- Cmatrix(icheb2,icheb1)=dcos(icheb1*pi*((Ncheb-icheb2)+0.5D0)/(Ncheb+1))
- end do
-end do
-end subroutine getCmatrix
+! set vnspll as twice as large
-subroutine create_Umatrix(theta,phi,lmmax,Umat,Udeggamat)
-implicit none
-!***********************************************************************
-! create the rotation matrix:
-! | cos(theta/2) exp(-i/2 phi) -sin(theta/2) exp(-i/2 phi) |
-! U= | |
-! | sin(theta/2) exp( i/2 phi) cos(theta/2) exp( i/2 phi) |
-!
-! Udegga = transpose(complex conjug ( U ) )
-!***********************************************************************double
-!precision :: phi
-!interface
-double precision,intent(in) :: phi
-double precision,intent(in) :: theta
-integer,intent(in) :: lmmax
-double complex,intent(out) :: Umat(2*lmmax,2*lmmax)
-double complex,intent(out) :: Udeggamat(2*lmmax,2*lmmax)
-!local
-double complex :: Umat11,Umat12,Umat21,Umat22
-double complex :: Udeggamat11,Udeggamat12,Udeggamat21,Udeggamat22
-integer :: ival
-double complex,parameter :: ci=(0.0D0,1.0D0)
-character*25 :: spinmode
+vnspll0(1:lmmax,1:lmmax,irmin:irc)= vnspll(1:lmmax,1:lmmax,irmin:irc,1)
-spinmode='kkr'
-if (spinmode=='regular') then
- Umat11 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
- Umat12 = -sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
- Umat21 = sin(theta/2.0D0)*exp( ci/2.0D0*phi)
- Umat22 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
-else if (spinmode=='kkr') then
- Umat11 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
- Umat12 = sin(theta/2.0D0)*exp( ci/2.0D0*phi)
- Umat21 = -sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
- Umat22 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
-else
- stop '[create_Umatrix] mode not known'
-end if
+vnspll0(lmmax+1:lmmaxso,lmmax+1:lmmaxso,irmin:irc)= &
+ vnspll(1:lmmax,1:lmmax,irmin:irc,nspin)
+END SUBROUTINE vllmat
-Umat=(0.0D0,0.0D0)
-do ival=1,lmmax
- Umat( ival, ival) = Umat11
- Umat( ival,lmmax+ival) = Umat12
- Umat(lmmax+ival,ival) = Umat21
- Umat(lmmax+ival,lmmax+ival) = Umat22
-end do
-if (spinmode=='regular') then
-Udeggamat11 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
-Udeggamat12 = sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
-Udeggamat21 = -sin(theta/2.0D0)*exp( ci/2.0D0*phi)
-Udeggamat22 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
-else if (spinmode=='kkr') then
-Udeggamat11 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
-Udeggamat12 = -sin(theta/2.0D0)*exp( ci/2.0D0*phi)
-Udeggamat21 = sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
-Udeggamat22 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
-else
- stop '[create_Umatrix] mode not known'
-end if
+SUBROUTINE spinorbit_ham(lmax,lmmaxd,vins,rnew,e,z,c,socscale, &
+ nspin,lmpotd,theta,phi, &
+ ipan_intervall,rpan_intervall, &
+ npan_tot,ncheb,irmdnew,nrmaxd,vnspll,vnspll1, &
+ mode,soc)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-18 Time: 14:28:35
+
+IMPLICIT NONE
+
+INTEGER, INTENT(IN) :: lmax
+INTEGER, INTENT(IN) :: lmmaxd
+DOUBLE PRECISION, INTENT(IN) :: vins(irmdnew,lmpotd,nspin)
+DOUBLE PRECISION, INTENT(IN) :: rnew(nrmaxd)
+DOUBLE COMPLEX, INTENT(IN OUT) :: e
+DOUBLE PRECISION, INTENT(IN) :: z
+DOUBLE PRECISION, INTENT(IN) :: c
+DOUBLE PRECISION, INTENT(IN) :: socscale
+!INTEGER, INTENT(IN) :: nsra
+INTEGER, INTENT(IN) :: nspin
+INTEGER, INTENT(IN) :: lmpotd
+DOUBLE PRECISION, INTENT(IN) :: theta
+DOUBLE PRECISION, INTENT(IN) :: phi
+INTEGER, INTENT(IN) :: ipan_intervall(0:)
+DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
+INTEGER, INTENT(IN) :: npan_tot
+INTEGER, INTENT(IN) :: ncheb
+INTEGER, INTENT(IN) :: irmdnew
+INTEGER, INTENT(IN OUT) :: nrmaxd
+DOUBLE COMPLEX, INTENT(IN) :: vnspll(:,:,:)
+DOUBLE COMPLEX, INTENT(OUT) :: vnspll1(:,:,:)
+CHARACTER(LEN=*), INTENT(IN) :: mode
+LOGICAL, INTENT(IN) :: soc !switches SOC on and off
-Udeggamat=(0.0D0,0.0D0)
-do ival=1,lmmax
- Udeggamat( ival, ival) = Udeggamat11
- Udeggamat( ival,lmmax+ival) = Udeggamat12
- Udeggamat(lmmax+ival,ival) = Udeggamat21
- Udeggamat(lmmax+ival,lmmax+ival) = Udeggamat22
-end do
-end subroutine create_Umatrix
-SUBROUTINE spin_orbit_one_l(lmax,l_s)
+DOUBLE PRECISION :: vr(irmdnew),dvdr(irmdnew)
+DOUBLE PRECISION :: rmass(irmdnew),hsofac(irmdnew)
+DOUBLE PRECISION :: rnucl,atn,widthfac
+INTEGER :: ir,ip,lm1,lm2,ispin,irmin,irmax,ncoll
+DOUBLE COMPLEX lsmh(2*lmmaxd,2*lmmaxd),temp
+DOUBLE PRECISION :: clambdacinv(0:ncheb,0:ncheb)
+!DOUBLE PRECISION :: matvec_dmdm
+LOGICAL :: test,opt
+EXTERNAL test,opt
-IMPLICIT NONE
+vnspll1=(0D0,0D0)
+vr=0D0
+DO ispin=1,nspin
+ DO ir=1,ipan_intervall(npan_tot)
+ vr(ir)=vr(ir)+vins(ir,1,ispin)/nspin
+ END DO
+END DO
+! derivative of potential
+dvdr=0D0
+CALL getclambdacinv(ncheb,clambdacinv)
+DO ip=1,npan_tot
+ irmin=ipan_intervall(ip-1)+1
+ irmax=ipan_intervall(ip)
+ widthfac= 2D0/(rpan_intervall(ip)-rpan_intervall(ip-1))
+ CALL dgemv('N',ncheb+1,ncheb+1,1D0,clambdacinv,ncheb+1, &
+ vr(irmin:irmax),1,0D0,dvdr(irmin:irmax),1)
+ dvdr(irmin:irmax)= dvdr(irmin:irmax)*widthfac
+END DO
+! core potential
+IF (z > 24D0) THEN
+ atn=-16.1532921+2.70335346*z
+ELSE
+ atn=0.03467714+2.04820786*z
+END IF
+rnucl=1.2D0/0.529177D0*atn**(1./3D0)*1.d-5
-INTEGER, INTENT(IN) :: lmax
-DOUBLE COMPLEX, INTENT(OUT) :: l_s((2*lmax+1)*2,(2*lmax+1)*2)
-! ************************************************************************
-! in this subroutine the matrix L*S is calculated for the basis of
-! real spherical harmonics
+DO ir=1,ipan_intervall(npan_tot)
+ IF (rnew(ir) <= rnucl) THEN
+! DVDR(IR)=DVDR(IR)+2d0*Z*RNEW(IR)/RNUCL**3d0
+ ELSE
+! DVDR(IR)=DVDR(IR)+2d0*Z/RNEW(IR)**2d0
+ END IF
+ dvdr(ir)=dvdr(ir)+2D0*z/rnew(ir)**2D0
+END DO
+! contruct LS matrix
-! schematically it has the form
-! ( -L_z L_+ )
-! ( L_- L_z )
+CALL spin_orbit_compl(lmax,lmmaxd,lsmh)
+! roate LS matrix
+ncoll=1
+IF (ncoll == 1) THEN
+ CALL rotatematrix(lsmh,theta,phi,lmmaxd,1)
+END IF
+IF (mode == 'transpose') THEN
+ DO lm1=1,2*lmmaxd
+ DO lm2=1,lm1-1
+ temp=lsmh(lm2,lm1)
+ lsmh(lm2,lm1)=lsmh(lm1,lm2)
+ lsmh(lm1,lm2)=temp
+ END DO
+ END DO
+ELSE IF (mode == '1') THEN
+END IF
+! contruct prefactor of spin-orbit hamiltonian
+hsofac=0D0
+DO ir=1,irmdnew
+ rmass(ir)=0.5D0-0.5D0/c**2*((vr(ir)-REAL(e))-2D0*z/rnew(ir))
+ IF (soc .eqv. .false. .OR. z < 1D-6) THEN
+ hsofac(ir)=0D0
+ ELSE
+ hsofac(ir)=socscale/(2D0*rmass(ir)**2*c**2*rnew(ir))*dvdr(ir)
+ END IF
+
+! add to potential
+
+ DO lm1=1,2*lmmaxd
+ DO lm2=1,2*lmmaxd
+ vnspll1(lm1,lm2,ir)=vnspll(lm1,lm2,ir)+hsofac(ir)*lsmh(lm1,lm2)
+ END DO
+ END DO
+END DO
+END SUBROUTINE spinorbit_ham
-! local variables
-INTEGER :: i1,i2,i1l
-DOUBLE COMPLEX :: icompl
-DOUBLE COMPLEX,allocatable :: l_min(:,:)
-DOUBLE COMPLEX,allocatable :: l_up(:,:)
-DOUBLE PRECISION :: lfac
+subroutine vllmatsra(vll0,vll,rmesh,lmsize,nrmax,nrmaxd,eryd,cvlight,lmax,lval_in,cmode)
+!************************************************************************************
+! The perubation matrix for the SRA-equations are set up
+!************************************************************************************
+implicit none
+!interface
+ DOUBLE COMPLEX VLL(2*lmsize,2*lmsize,nrmax)
+ DOUBLE COMPLEX VLL0(lmsize,lmsize,nrmax)
+ double precision :: rmesh(nrmaxd)
+ double complex :: eryd
+ double precision :: cvlight
+ integer :: lmax,lval_in
+ integer :: lmsize,nrmax,nrmaxd
+ character(len=*) :: cmode
+!local
+ integer :: ilm,lval,mval,ival,ir
+ integer :: loflm(lmsize)
+ double complex :: Mass,Mass0
+ double complex,parameter :: cone=(1.0D0,0.0D0)
+ double complex,parameter :: czero=(0.0D0,0.0D0)
-icompl=(0D0,1D0)
+!************************************************************************************
+! determine the bounds of the matricies to get the lm-expansion and the max. number
+! of radial points
+!************************************************************************************
-allocate(l_min(-lmax:lmax,-lmax:lmax))
-allocate(l_up(-lmax:lmax,-lmax:lmax))
-! initialize the matrix
+!************************************************************************************
+! calculate the index array to determine the L value of an LM index
+! in case of spin-orbit coupling 2*(LMAX+1)**2 are used instead of (LMAX+1)**2
+! the second half refers to the second spin and has the the same L value
+!************************************************************************************
+ilm=0
-DO i1=1,(2*lmax+1)*2
- DO i2=1,(2*lmax+1)*2
- l_s(i2,i1)=0D0
- END DO
-END DO
+if (lmsize==1) then
+ loflm(1)=lval_in
+elseif ((lmax+1)**2 == lmsize) then
+ do lval=0,lmax
+ do mval = -lval,lval
+ ilm=ilm+1
+ loflm(ilm)=lval
+ end do
+ end do
+elseif (2* (lmax+1)**2 ==lmsize ) then
+ do ival=1,2
+ do lval=0,lmax
+ do mval = -lval,lval
+ ilm=ilm+1
+ loflm(ilm)=lval
+ end do
+ end do
+ end do
+else
+ stop '[vllmatsra] error'
+end if
-DO i1=-lmax,lmax
- DO i2=-lmax,lmax
- l_min(i2,i1)=0D0
- l_up(i2,i1)=0D0
- END DO
-END DO
-! fill the second and the forth quadrant with L_z
-! (-L_z,respectively)
-DO i1=1,2*lmax+1
- i1l=i1-lmax-1 ! the value of m (varies from -l to +l)
- i2=2*lmax+1-(i1-1)
-
-! L_S(i2,i1)=icompl*i1l
- l_s(i2,i1)=-icompl*i1l
-
-END DO
+vll=(0.0D0,0d0)
-DO i1=2*lmax+2,(2*lmax+1)*2
- i1l=i1-lmax-1-(2*lmax+1) ! the value of m (varies from -l to +l)
- i2=(2*lmax+1)*2-(i1-(2*lmax+2))
-
-! L_S(i2,i1)=-icompl*i1l
- l_s(i2,i1)=icompl*i1l
-
-END DO
-! implement now L_- in the third quadrant
-IF (lmax>0) THEN
-
- lfac=SQRT(lmax*(lmax+1D0))/SQRT(2D0)
- l_min(0,-1)=-icompl*lfac
-! l_min(0,-1)=icompl*lfac
- l_min(0,1)=lfac
- l_min(-1,0)=icompl*lfac
- l_min(1,0)=-lfac
-
- IF (lmax > 1) THEN
-
- DO i1=2,lmax
-
- lfac=0.5D0*SQRT(lmax*(lmax+1D0)-i1*(i1-1D0))
- l_min(-i1,-i1+1)=-lfac
- l_min(-i1,i1-1)=icompl*lfac
- l_min(i1,-i1+1)=-icompl*lfac
- l_min(i1,i1-1)=-lfac
-
- lfac=0.5D0*SQRT(lmax*(lmax+1D0)-(i1-1)*(i1))
- l_min(-i1+1,-i1)=lfac
- l_min(-i1+1,i1)=icompl*lfac
- l_min(i1-1,-i1)=-icompl*lfac
- l_min(i1-1,i1)=lfac
-
- END DO
-
- END IF
-END IF
+if (cmode=='Ref=0') then
+ vll(1:lmsize,1:lmsize,:)= vll0 !/cvlight
+ do ir=1,nrmax
+ do ival=1,lmsize
+ lval=loflm(ival)
+ Mass =cone+(eryd-vll0(ival,ival,ir))/cvlight**2
+ Mass0=cone+eryd/cvlight**2
-DO i1=-lmax,lmax
- DO i2=-lmax,lmax
- l_s(i2+3*lmax+2,i1+lmax+1)=l_min(i1,i2)
- END DO
-END DO
+ !************************************************************************************
+ ! Conventional potential matrix
+ !************************************************************************************
+ vll(lmsize+ival,lmsize+ival,ir)= -vll0(ival,ival,ir)/cvlight**2 ! TEST 9/22/2011
+ vll(ival,ival,ir)=vll(ival,ival,ir)+ (1.0D0/Mass-1.0D0/Mass0)*lval*(lval+1)/rmesh(ir)**2
-! implement now L_+ in the quadrant
+ !************************************************************************************
+ ! The pertubation matrix is changed in the following way
+ !
+ ! from / V11 V12 \ to / V21 V22 \
+ ! \ V21 V22 / \-V11 -V12 /
+ ! because of the convention used for the left solution
+ !************************************************************************************
+ end do !ival
-IF (lmax>0) THEN
-
- lfac=SQRT(lmax*(lmax+1D0))/SQRT(2D0)
- l_up(0,-1)=-icompl*lfac
- l_up(0,1)=-lfac
- l_up(-1,0)=icompl*lfac
- l_up(1,0)=lfac
-
- IF (lmax > 1) THEN
-
- DO i1=2,lmax
-
- lfac=0.5D0*SQRT(lmax*(lmax+1D0)-i1*(i1-1D0))
- l_up(-i1,-i1+1)=lfac
- l_up(-i1,i1-1)=icompl*lfac
- l_up(i1,-i1+1)=-icompl*lfac
- l_up(i1,i1-1)=lfac
-
- lfac=0.5D0*SQRT(lmax*(lmax+1D0)-(i1-1)*(i1))
- l_up(-i1+1,-i1)=-lfac
- l_up(-i1+1,i1)=icompl*lfac
- l_up(i1-1,-i1)=-icompl*lfac
- l_up(i1-1,i1)=-lfac
-
- END DO
-
- END IF
-END IF
+ end do !ir
+elseif (cmode=='Ref=Vsph') then
+ vll(lmsize+1:2*lmsize,1:lmsize,:)=vll0
+endif
-DO i1=-lmax,lmax
- DO i2=-lmax,lmax
- l_s(i2+lmax+1,i1+3*lmax+2)=l_up(i1,i2)
- END DO
-END DO
+end subroutine vllmatsra
+subroutine rllsllsourceterms(nsra,nvec,eryd,rmesh,nrmax,nrmaxd,lmax,lmsize,use_fullgmat,jlk_index,hlk,jlk,hlk2,jlk2,GMATPREFACTOR)
+implicit none
+! ************************************************************************
+! calculates the source terms J,H and the left solution J2, H2 for:
+! - non-relativistic
+! - scalar-relativistic
+! - full-relativistic
+! calculations
+! ************************************************************************
+double complex,parameter :: ci=(0.0d0,1.0d0)
+double precision :: cvlight
+parameter (cvlight=274.0720442D0)
+integer :: nsra,lmax,nrmax,nrmaxd,nvec
+double complex :: eryd
+double precision :: rmesh(nrmaxd)
+integer :: jlk_index(2*lmsize)
+integer :: l1,lm1,m1,ivec,ispinfullgmat,ir
+integer :: use_fullgmat
+integer :: lmsize
-deallocate(l_min)
-deallocate(l_up)
+double complex :: ek,ek2,gmatprefactor
+double complex :: hlk(1:4*(lmax+1),nrmax),jlk(1:4*(lmax+1),nrmax)
+double complex :: hlk2(1:4*(lmax+1),nrmax),jlk2(1:4*(lmax+1),nrmax)
+if (nsra==2) then
+ nvec=2
+elseif (nsra==1) then
+ nvec=1
+end if
-END SUBROUTINE spin_orbit_one_l
-SUBROUTINE rhovalnew(ldorhoef,ielast,nsra,nspin,lmax,ez,wez,zat, &
- socscale,cleb,icleb,iend,ifunm,lmsp,ncheb, &
- npan_tot,npan_log,npan_eq,rmesh,irws, &
- rpan_intervall,ipan_intervall, &
- rnew,vinsnew,thetasnew,theta,phi,angle_fixed, &
- moment_x,moment_y,moment_z, &
- ipot, &
- den_out,espv,rho2ns,r2nef,gmatn, muorb, &
- lpotd,lmaxd,irmd,irmd_new,iemxd,soc) ! new parameters
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-21 Time: 11:39:57
+ lm1 = 1
+ do ivec=1,nvec
+ do ispinfullgmat=0,use_fullgmat
+ do l1 = 0,lmax
+ do m1 = -l1,l1
+ jlk_index(lm1) = l1+(ivec-1)*(lmax+1)+1
+ lm1 = lm1 + 1
+ end do
+ end do
+ end do!ispinorbit=0,use_fullgmat
+ end do !nvec
-
-#ifdef CPP_OMP
- use omp_lib
-#endif
-IMPLICIT NONE
+if (nsra==1) then
+ ek = sqrt(eryd)
+ ek2 = sqrt(eryd)
+elseif (nsra==2) then
+ ek = sqrt(eryd+(eryd/cvlight)**2)
+ ek2 = sqrt(eryd+(eryd/cvlight)**2) *(1.0d0+eryd/cvlight**2)
+end if
-LOGICAL, INTENT(IN) :: ldorhoef
-INTEGER, INTENT(IN) :: ielast
-INTEGER, INTENT(IN) :: nsra
-INTEGER, INTENT(IN) :: nspin
-INTEGER, INTENT(IN) :: lmax
-DOUBLE COMPLEX, INTENT(IN) :: ez(:)
-DOUBLE COMPLEX, INTENT(IN) :: wez(:)
-DOUBLE PRECISION, INTENT(IN) :: zat
-DOUBLE PRECISION, INTENT(IN) :: socscale
-DOUBLE PRECISION, INTENT(IN) :: cleb(:)
-INTEGER, INTENT(IN) :: icleb(:,:)
-INTEGER, INTENT(IN) :: iend
-INTEGER, INTENT(IN) :: ifunm(:)
-INTEGER, INTENT(IN) :: lmsp(:)
-INTEGER, INTENT(IN) :: ncheb
-INTEGER, INTENT(IN) :: npan_tot
-INTEGER, INTENT(IN) :: npan_log
-INTEGER, INTENT(IN) :: npan_eq
-DOUBLE PRECISION, INTENT(IN) :: rmesh(:)
-INTEGER, INTENT(IN) :: irws
-DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(0:)
-INTEGER, INTENT(IN) :: ipan_intervall(0:)
-DOUBLE PRECISION, INTENT(IN) :: rnew(:)
-DOUBLE PRECISION, INTENT(IN) :: vinsnew(:,:,:)
-DOUBLE PRECISION, INTENT(IN) :: thetasnew(:,:)
-DOUBLE PRECISION, INTENT(INOUT) :: theta
-DOUBLE PRECISION, INTENT(INOUT) :: phi
-INTEGER (kind=1), INTENT(IN) :: angle_fixed
-DOUBLE PRECISION, INTENT(OUT) :: moment_x
-DOUBLE PRECISION, INTENT(OUT) :: moment_y
-DOUBLE PRECISION, INTENT(OUT) :: moment_z
-!INTEGER, INTENT(IN) :: i1
-INTEGER, INTENT(IN) :: ipot
-DOUBLE COMPLEX, INTENT(OUT) :: den_out(0:,:,:)
-DOUBLE PRECISION, INTENT(OUT) :: espv(0:,:)
-DOUBLE PRECISION, INTENT(OUT) :: rho2ns(:,:,:)
-DOUBLE PRECISION, INTENT(OUT) :: r2nef(:,:,:)
-DOUBLE COMPLEX, INTENT(IN) :: gmatn(:,:,:)
-DOUBLE PRECISION, INTENT(OUT) :: muorb(0:,:)
-INTEGER, INTENT(IN) :: lpotd
-INTEGER, INTENT(IN) :: lmaxd
-INTEGER, INTENT(IN) :: irmd
-INTEGER, INTENT(IN) :: irmd_new
-INTEGER, INTENT(IN) :: iemxd
-LOGICAL, INTENT(IN) :: soc
-!INCLUDE 'inc.p'
+
+do ir = 1,nrmax
-!INTEGER, PARAMETER :: lmmaxd= (lmaxd+1)**2
+ call beshank(hlk(:,ir),jlk(:,ir),ek*rmesh(ir),lmax)
+ if (nsra==2) then
+ call beshank_smallcomp(hlk(:,ir),jlk(:,ir),&
+ ek*rmesh(ir),rmesh(ir),eryd,lmax)
+ end if
-!INTEGER, PARAMETER :: lmaxd1= lmaxd+1
+ do l1 = 1,nvec*(lmax+1)
+ hlk(l1,ir) = -ci*hlk(l1,ir)
+ end do
-!INTEGER, PARAMETER :: lmmaxso=2*lmmaxd
-!INTEGER :: lmpotd
-!DOUBLE PRECISION, INTENT, PARAMETER :: lmpotd= (lpotd+1)**2
+ if (nsra==1) then
+ do l1 = 1,nvec*(lmax+1)
+ jlk2(l1,ir) = jlk(l1,ir)
+ hlk2(l1,ir) = hlk(l1,ir)
+ end do
+ else if (nsra==2) then
+ do l1 = 1,lmax+1
+ jlk2(l1,ir) = jlk(l1,ir)
+ hlk2(l1,ir) = hlk(l1,ir)
+ end do
+ do l1 = lmax+2,2*(lmax+1)
+ jlk2(l1,ir) = -jlk(l1,ir)
+ hlk2(l1,ir) = -hlk(l1,ir)
+ end do
+ end if
-!INTEGER, PARAMETER :: lmxspd= (2*lpotd+1)**2
+end do
+gmatprefactor=ek2
+end subroutine rllsllsourceterms
-DOUBLE PRECISION, PARAMETER :: cvlight=274.0720442D0
-DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
-DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
+subroutine getCLambdaCinv(Ncheb,CLambdaCinv)
+implicit none
+! set up the Lambda matrix which differentiates the coefficients of an
+! Chebyshev expansion
+integer :: Ncheb
+double precision :: CLambdaCinv(0:Ncheb,0:Ncheb)
+!local
+double precision :: Lambda(0:Ncheb,0:Ncheb)
+double precision :: Cmatrix(0:Ncheb,0:Ncheb)
+double precision :: Cinvmatrix(0:Ncheb,0:Ncheb)
+double precision :: temp1(0:Ncheb,0:Ncheb)
+EXTERNAL dgemm
+integer n
+ Lambda=(0.0D0,0.0D0)
+ Cmatrix=(0.0D0,0.0D0)
+ Cinvmatrix=(0.0D0,0.0D0)
+ Lambda=(0.0D0,0.0D0)
+ temp1=(0.0D0,0.0D0)
-!INTEGER, PARAMETER :: nrmaxd=ntotd*(nchebd+1)
+call getLambda(Ncheb,Lambda)
+call getCinvmatrix(Ncheb,Cinvmatrix)
+call getCmatrix(Ncheb,Cmatrix)
+n=Ncheb+1
+ call dgemm('N','N',n,n,n,1d0,Lambda,n,Cinvmatrix,n,0d0,temp1,n)
+ call dgemm('N','N',n,n,n,1d0,Cmatrix,n,temp1,n,0d0,CLambdaCinv,n)
+! temp1=matmat_dmdm(Lambda,Cinvmatrix,Ncheb)
+! CLambdaCinv=matmat_dmdm(Cmatrix,temp1,Ncheb)
-INTEGER :: lmmaxd, lmaxd1, lmmaxso, lmpotd, lmxspd, nrmaxd
-DOUBLE COMPLEX eryd, ek,df
+end subroutine
-
-DOUBLE COMPLEX, allocatable :: tmatll(:,:), &
- tmattemp(:,:)
-DOUBLE COMPLEX, allocatable :: gmatll(:,:,:), gmat0(:,:)
-INTEGER :: ir,use_sratrick,nvec,lm1,lm2,ie,irmdnew,imt1, &
- jspin,idim,iorb
-DOUBLE PRECISION :: pi,thetanew,phinew
-DOUBLE COMPLEX gmatprefactor
-DOUBLE PRECISION, allocatable :: vins(:,:,:)
-DOUBLE COMPLEX,allocatable :: vnspll0(:,:,:),vnspll1(:,:,:,:), vnspll(:,:,:,:)
-DOUBLE COMPLEX, allocatable :: hlk(:,:,:),jlk(:,:,:), hlk2(:,:,:),jlk2(:,:,:)
-DOUBLE COMPLEX, allocatable :: rll(:,:,:,:), &
- rllleft(:,:,:,:),sllleft(:,:,:,:)
-DOUBLE COMPLEX, allocatable :: tmatsph(:,:)
-DOUBLE COMPLEX, allocatable :: cden(:,:,:,:), &
- cdenlm(:,:,:,:),cdenns(:,:,:),rho2nsc(:,:,:),r2nefc(:,:,:), &
- rho2nsnew(:,:,:),r2nefnew(:,:,:),r2orbc(:,:,:,:), &
- gflle_part(:,:,:),gflle(:,:,:,:),rho2nsc_loop(:,:,:,:), r2nefc_loop(:,:,:,:)
+subroutine rotatematrix(mat,theta,phi,lmmax,mode)
+! rotates a matrix in the local frame pointing in
+! the direction of phi and theta to the global frame
+implicit none
+!interface
+double complex,intent(inout) :: mat(2*lmmax,2*lmmax)
+double precision,intent(in) :: phi
+double precision,intent(in) :: theta
+integer :: lmmax
+integer :: mode
+!local
+double complex :: Umat(2*lmmax,2*lmmax)
+double complex :: Udeggamat(2*lmmax,2*lmmax)
+double complex :: mattemp(2*lmmax,2*lmmax)
+!double precision :: matmat_zmzm
-DOUBLE COMPLEX, allocatable:: den(:,:,:,:),denlm(:,:,:,:)
-DOUBLE COMPLEX rho2(4),rho2int(4),temp1
+!***********************************************************************
+! create the rotation matrix:
+! | cos(theta/2) exp(-i/2 phi) -sin(theta/2) exp(-i/2 phi) |
+! U= | |
+! | sin(theta/2) exp( i/2 phi) cos(theta/2) exp( i/2 phi) |
+!
+! Udegga = transpose(complex conjug ( U ) )
+!***********************************************************************
-DOUBLE COMPLEX rho2ns_temp(2,2),dentemp
-DOUBLE PRECISION :: moment(3),totmoment,totxymoment
-DOUBLE PRECISION :: denorbmom(3),denorbmomsp(2,4), &
- denorbmomlm(0:lmaxd,3),denorbmomns(3)
-DOUBLE COMPLEX, allocatable :: cdentemp(:,:), rhotemp(:,:),rhonewtemp(:,:)
-INTEGER, allocatable :: jlk_index(:)
-LOGICAL :: test,opt
-EXTERNAL test,opt
-!DOUBLE PRECISION :: qvec(:,:) ! qdos ruess: q-vectors for qdos
-!allocatable qvec ! qdos ruess
-!DOUBLE COMPLEX dentot(2) ! qdos ruess
-!DOUBLE COMPLEX, allocatable :: dentmp(:,:) ! qdos ruess
-INTEGER :: iq,nqdos ! qdos ruess: number of qdos points
-!INTEGER :: m1,lmshift1(4),lmshift2(4) !, ix ! qdos ruess
-!INTEGER :: lrecgflle,ierr ! lmlm-dos
-! OMP - number of threads, thread id
-INTEGER :: nth,ith
+call create_Umatrix(theta,phi,lmmax,Umat,Udeggamat)
+!***********************************************************************
+! calculate matrix in the global frame:
+!
+! t_glob = U * t_loc * Udegga
+!***********************************************************************
-lmmaxd = (lmaxd+1)**2
-lmaxd1 = lmaxd+1
-lmmaxso = 2*lmmaxd
-lmpotd = (lpotd+1)**2
-lmxspd = (2*lpotd+1)**2
-nrmaxd=irmd_new
-allocate(tmatll(lmmaxso,lmmaxso))
-allocate(tmattemp(lmmaxso,lmmaxso))
-allocate(gmatll(lmmaxso,lmmaxso,iemxd))
-allocate(gmat0(lmmaxso,lmmaxso))
-!allocate(dentmp(0:lmaxd1,2))
-allocate(jlk_index(2*lmmaxso))
+if (mode==0) then ! 'loc->glob'
+ call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),mat,2*lmmax,Udeggamat,2*lmmax,(0d0,0d0),mattemp,2*lmmax)
+ call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),Umat,2*lmmax,mattemp,2*lmmax,(0d0,0d0),mat,2*lmmax)
+elseif (mode==1) then !'glob->loc'
+ call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),mat,2*lmmax,Umat,2*lmmax,(0d0,0d0),mattemp,2*lmmax)
+ call zgemm('N','N',2*lmmax,2*lmmax,2*lmmax,(1d0,0d0),Udeggamat,2*lmmax,mattemp,2*lmmax,(0d0,0d0),mat,2*lmmax)
+else
+ stop '[rotatematrix] mode not known'
+end if
+! writE(324,'(5000F)') tmat
+! stop
+end subroutine rotatematrix
-! determine if omp is used
- ith = 0
- nth = 1
-#ifdef CPP_OMP
-!$omp parallel shared(nth,ith)
-!$omp single
- nth = omp_get_num_threads()
-!$omp end single
-!$omp end parallel
-#endif
-pi=4D0*DATAN(1D0)
-irmdnew= npan_tot*(ncheb+1)
-imt1=ipan_intervall(npan_log+npan_eq)+1
-allocate(vins(irmdnew,lmpotd,nspin))
-vins=0D0
-DO lm1=1,lmpotd
- DO ir=1,irmdnew
- vins(ir,lm1,1)=vinsnew(ir,lm1,ipot)
- vins(ir,lm1,nspin)=vinsnew(ir,lm1,ipot+nspin-1)
- END DO
-END DO
+SUBROUTINE spin_orbit_compl(lmax,lmmaxd,l_s)
-!c set up the non-spherical ll' matrix for potential VLL'
-IF (NSRA.EQ.2) THEN
-USE_SRATRICK=1
-ELSE
-USE_SRATRICK=0
-ENDIF
-allocate(vnspll0(lmmaxso,lmmaxso,irmdnew))
-allocate(vnspll1(lmmaxso,lmmaxso,irmdnew,0:nth-1))
-vnspll0=czero
-CALL vllmat(1,irmdnew,lmmaxd,lmmaxso,vnspll0,vins, &
- cleb,icleb,iend,nspin,zat,rnew,use_sratrick)
+IMPLICIT NONE
-! initial allocate
-IF (nsra == 2) THEN
- allocate(vnspll(2*lmmaxso,2*lmmaxso,irmdnew,0:nth-1))
-ELSE
- allocate(vnspll(lmmaxso,lmmaxso,irmdnew,0:nth-1))
-END IF
+INTEGER, INTENT(IN) :: lmax
+INTEGER, INTENT(IN) :: lmmaxd
+DOUBLE COMPLEX, INTENT(OUT):: l_s(:,:)
+! ************************************************************************
+! in this subroutine the matrix L*S is calculated for the basis of
+! real spherical harmonics
-allocate(hlk(4*(lmax+1),irmdnew,0:nth-1))
-allocate(jlk(4*(lmax+1),irmdnew,0:nth-1))
-allocate(hlk2(4*(lmax+1),irmdnew,0:nth-1))
-allocate(jlk2(4*(lmax+1),irmdnew,0:nth-1))
-allocate(tmatsph(2*(lmax+1),0:nth-1))
-allocate(rll(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-allocate(rllleft(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-allocate(sllleft(nsra*lmmaxso,lmmaxso,irmdnew,0:nth-1))
-allocate(cden(irmdnew,0:lmaxd,4,0:nth-1))
-allocate(cdenlm(irmdnew,lmmaxd,4,0:nth-1))
-allocate(cdenns(irmdnew,4,0:nth-1))
-allocate(rho2nsc(irmdnew,lmpotd,4))
-allocate(rho2nsc_loop(irmdnew,lmpotd,4,ielast))
-allocate(rho2nsnew(irmd,lmpotd,4))
-allocate(r2nefc(irmdnew,lmpotd,4))
-allocate(r2nefc_loop(irmdnew,lmpotd,4,0:nth-1))
-allocate(r2nefnew(irmd,lmpotd,4))
-allocate(r2orbc(irmdnew,lmpotd,4,0:nth-1))
-allocate(cdentemp(irmdnew,0:nth-1))
-allocate(gflle_part(lmmaxso,lmmaxso,0:nth-1))
-allocate(gflle(lmmaxso,lmmaxso,ielast,1))
-allocate(den(0:lmaxd1,iemxd,2,1),denlm(lmmaxd,iemxd,2,1))
-rho2nsc=czero
-rho2nsc_loop=czero
-r2nefc=czero
-r2nefc_loop=czero
-r2orbc=czero
-rho2ns=0.d0 ! fivos 19.7.2014, this was CZERO
-r2nef=0.d0 ! fivos 19.7.2014, this was CZERO
-rho2nsnew=czero
-r2nefnew=czero
-den=czero
-espv=0D0
-rho2int=czero
-denorbmom=0D0
-denorbmomsp=0D0
-denorbmomlm=0D0
-denorbmomns=0D0
-thetanew=0D0
-phinew=0D0
-gflle_part=czero
-gflle=czero
-! LM shifts for correct density summation
-!lmshift1(1)=0 ! qdos ruess
-!lmshift1(2)=lmmaxd ! qdos ruess
-!lmshift1(3)=0 ! qdos ruess
-!lmshift1(4)=lmmaxd ! qdos ruess
-!lmshift2(1)=0 ! qdos ruess
-!lmshift2(2)=lmmaxd ! qdos ruess
-!lmshift2(3)=lmmaxd ! qdos ruess
-!lmshift2(4)=0 ! qdos ruess
-GMAT0 = czero
-gmatll = czero
+! local variableINTEGER :: i1,i2,i1l,rl,lm1,lm2
+INTEGER :: rl,lm1,lm2
+DOUBLE COMPLEX,allocatable :: ls_l(:,:)
-DO ir=1,3
- DO lm1=0,lmaxd1+1
- muorb(lm1,ir)=0D0
- END DO
-END DO
- nqdos = 1 ! qdos ruess
-!IF (opt('qdos ')) THEN ! qdos ruess
-! Read BZ path for qdos calculation: ! qdos ruess
-! OPEN(67,FILE='qvec.dat',STATUS='old',IOSTAT=ierr,ERR=3000) ! qdos ruess
-! READ(67,*) nqdos ! qdos ruess
-! allocate(qvec(3,nqdos)) ! qdos ruess
-! DO iq = 1,nqdos ! qdos ruess
-! READ(67,*) (qvec(ix,iq),ix=1,3) ! qdos ruess
-! END DO ! qdos ruess
-! CLOSE(67) ! qdos ruess
-! Change allocation for GFLLE to be suitabel for qdos run ! qdos ruess
-! deallocate(gflle,den,denlm) ! qdos ruess
-! allocate(gflle(lmmaxso,lmmaxso,ielast,nqdos)) ! qdos ruess
-! allocate(den(0:lmaxd1,iemxd,2,nqdos), denlm(lmmaxd,iemxd,2,nqdos))
-! 3000 IF (ierr /= 0) STOP 'ERROR READING ''QVEC.DAT''' ! QDOS Ruess
-!END IF ! OPT('qdos ') ! qdos ruess
-
-!IF ((opt('lmlm-dos')).AND.(i1 == 1)) THEN ! lmlm-dos ruess
-! lrecgflle = 4*lmmaxso*lmmaxso*ielast*nqdos ! lmlm-dos ruess
-! OPEN(91,ACCESS='direct',RECL=lrecgflle,FILE='gflle', ! lmlm-dos ruess &
-! FORM='unformatted',STATUS='replace',ERR=3001,IOSTAT=ierr)! lmlm-dos ruess
-! 3001 IF (ierr /= 0) STOP 'ERROR CREATING ''GFLLE''' ! LMLM-DOs ruess
-!END IF ! lmlm-dos ruess
-
-! energy loop
-!WRITE(6,*) 'atom: ',i1
-
-
-#ifdef CPP_OMP
-! omp: start parallel region here
-!$omp parallel do default(none) ,&
-!$omp& private(eryd,ie,ir,lm1,lm2,gmatprefactor,nvec) ,&
-!$omp& private(jlk_index,tmatll,ith) ,&
-!$omp& shared(nspin,nsra,iend,ipot,ielast,npan_tot,ncheb,lmax) ,&
-!$omp& shared(zat,socscale,ez,rmesh,cleb,rnew,nth,icleb,thetasnew) ,&
-!$omp& shared(rpan_intervall,vinsnew,ipan_intervall,r2nefc_loop) ,&
-!$omp& shared(use_sratrick,irmdnew,theta,phi,vins,vnspll0) ,&
-!$omp& shared(vnspll1,vnspll,hlk,jlk,hlk2,jlk2,rll,cdentemp) ,&
-!$omp& shared(tmatsph,den,denlm,gflle,gflle_part,rllleft,sllleft) ,&
-!$omp& private(iq,df,ek,tmattemp,gmatll,gmat0,iorb,dentemp) ,&
-!$omp& private(rho2ns_temp,rho2,temp1,jspin) ,&
-!$omp& shared(ldorhoef,nqdos,wez,lmsp,imt1,ifunm) ,&
-!$omp& shared(r2orbc,r2nefc,cden,cdenlm,cdenns,rho2nsc_loop) ,&
-!$omp& shared(lmaxd,lmaxd1,lmmaxd,lmpotd,nrmaxd,soc,lmmaxso,gmatn) ,&
-!$omp& reduction(+:rho2int,espv) reduction(-:muorb) ,&
-!$omp& reduction(-:denorbmom,denorbmomsp,denorbmomlm,denorbmomns)
-#endif
+!icompl=(0D0,1D0)
-DO ie=1,ielast
-#ifdef CPP_OMP
- ith = omp_get_thread_num()
-#else
- ith = 0
-#endif
-
- eryd=ez(ie)
- ek=SQRT(eryd)
- df=wez(ie)/DBLE(nspin)
- IF (nsra == 2) ek = SQRT( eryd + eryd*eryd/(cvlight*cvlight) ) * &
- ( 1D0 + eryd/(cvlight*cvlight) )
-!!$noomp critical
-! WRITE(6,*) 'energy:',ie,'',eryd
-!!$noomp end critical
-!
-! IREC=IE+IELAST*(I1-1)
-! READ(69,REC=IREC) GMAT0
-!
-! rotate gmat from global frame to local frame
-
-! GMAT0 = gmatn(:,:,ie)
-! CALL ROTATEMATRIX(GMAT0,THETA,PHI,LMMAXD,1)
-
-! DO LM1=1,LMMAXSO
-! DO LM2=1,LMMAXSO
-! GMATLL(LM1,LM2,IE)=GMAT0(LM1,LM2)
-! ENDDO
-! ENDDO
-
-! recalculate wavefuntions, also include left solution
-! contruct the spin-orbit coupling hamiltonian and add to potential
- CALL spinorbit_ham(lmax,lmmaxd,vins,rnew, &
- eryd,zat,cvlight,socscale,nspin,lmpotd, &
- theta,phi,ipan_intervall,rpan_intervall, npan_tot,ncheb,irmdnew,nrmaxd, &
- vnspll0,vnspll1(:,:,:,ith),'1',soc)
-
-!c extend matrix for the SRA treatment
- vnspll(:,:,:,ith)=czero
- IF (nsra == 2) THEN
- IF (use_sratrick == 0) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
- ELSE IF (use_sratrick == 1) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
- END IF
- ELSE
- vnspll(:,:,:,ith)=vnspll1(:,:,:,ith)
- END IF
-
-!c calculate the source terms in the Lippmann-Schwinger equation
-!c these are spherical hankel and bessel functions
- hlk(:,:,ith)=czero
- jlk(:,:,ith)=czero
- hlk2(:,:,ith)=czero
- jlk2(:,:,ith)=czero
- gmatprefactor=czero
- jlk_index=0
- CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
- lmmaxso,1,jlk_index,hlk(:,:,ith), &
- jlk(:,:,ith),hlk2(:,:,ith),jlk2(:,:,ith), gmatprefactor)
-
-! using spherical potential as reference
- IF (use_sratrick == 1) THEN
- CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
- rnew,vins,ncheb,npan_tot,rpan_intervall, &
- jlk_index,hlk(:,:,ith),jlk(:,:,ith),hlk2(:,:,ith), &
- jlk2(:,:,ith),gmatprefactor,tmatsph(:,ith), use_sratrick)
- END IF
+CALL cinit((2*lmmaxd)**2,l_s)
+
+DO rl=0,lmax
-!c calculate the tmat and wavefunctions
- rllleft(:,:,:,ith)=czero
- sllleft(:,:,:,ith)=czero
+ allocate(ls_l((2*rl+1)*2,(2*rl+1)*2))
+ CALL cinit(((2*rl+1)*2)**2,ls_l)
-!c right solutions
- tmatll=czero
- CALL rll_only(rpan_intervall,rnew,vnspll(:,:,:,ith), &
- rll(:,:,:,ith),tmatll, &
- ncheb,npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1), &
- irmdnew,nsra,jlk_index,hlk(:,:,ith),jlk(:,:,ith), &
- hlk2(:,:,ith),jlk2(:,:,ith), gmatprefactor,'1','1',use_sratrick)
- IF (nsra == 2) THEN
- rll(lmmaxso+1:nvec*lmmaxso,:,:,ith)= &
- rll(lmmaxso+1:nvec*lmmaxso,:,:,ith)/cvlight
- END IF
-! left solutions
-! contruct the TRANSPOSE spin-orbit coupling hamiltonian and add to potential
- CALL spinorbit_ham(lmax,lmmaxd,vins,rnew,eryd,zat, &
- cvlight,socscale,nspin,lmpotd,theta,phi, &
- ipan_intervall,rpan_intervall,npan_tot,ncheb, &
- irmdnew,nrmaxd,vnspll0,vnspll1(:,:,:,ith), 'transpose',soc)
+ CALL spin_orbit_one_l(rl,ls_l)
-!c extend matrix for the SRA treatment
- vnspll(:,:,:,ith)=czero
- IF (nsra == 2) THEN
- IF (use_sratrick == 0) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=0')
- ELSE IF (use_sratrick == 1) THEN
- CALL vllmatsra(vnspll1(:,:,:,ith),vnspll(:,:,:,ith),rnew, &
- lmmaxso,irmdnew,nrmaxd,eryd,cvlight,lmax,0,'Ref=Vsph')
+ DO lm1=1,(2*rl+1)*2
+
+ IF (lm1 <= 2*rl+1 ) THEN
+ DO lm2=1,(2*rl+1)
+ l_s(rl**2+lm1,rl**2+lm2)=0.5D0*ls_l(lm1,lm2)
+ END DO
+ DO lm2=(2*rl+1)+1,(2*rl+1)*2
+ l_s(rl**2+lm1,lmmaxd+rl**2-(2*rl+1)+lm2)= 0.5D0*ls_l(lm1,lm2)
+ END DO
+ ELSE
+ DO lm2=1,(2*rl+1)
+ l_s(lmmaxd+rl**2-(2*rl+1)+lm1,rl**2+lm2)= 0.5D0*ls_l(lm1,lm2)
+ END DO
+ DO lm2=(2*rl+1)+1,(2*rl+1)*2
+ l_s(lmmaxd+rl**2-(2*rl+1)+lm1,lmmaxd+rl**2-(2*rl+1)+lm2)= &
+ 0.5D0*ls_l(lm1,lm2)
+ END DO
END IF
- ELSE
- vnspll(:,:,:,ith)=vnspll1(:,:,:,ith)
- END IF
-
-!c calculate the source terms in the Lippmann-Schwinger equation
-!c these are spherical hankel and bessel functions
- hlk(:,:,ith)=czero
- jlk(:,:,ith)=czero
- hlk2(:,:,ith)=czero
- jlk2(:,:,ith)=czero
- gmatprefactor=czero
- jlk_index=0
- CALL rllsllsourceterms(nsra,nvec,eryd,rnew,irmdnew,nrmaxd,lmax, &
- lmmaxso,1,jlk_index,hlk(:,:,ith), &
- jlk(:,:,ith),hlk2(:,:,ith),jlk2(:,:,ith), gmatprefactor)
-
-!c using spherical potential as reference
-! notice that exchange the order of left and right hankel/bessel functions
- IF (use_sratrick == 1) THEN
- CALL calcsph(nsra,irmdnew,nrmaxd,lmax,nspin,zat,cvlight,eryd, &
- rnew,vins,ncheb,npan_tot,rpan_intervall, &
- jlk_index,hlk2(:,:,ith),jlk2(:,:,ith), &
- hlk(:,:,ith),jlk(:,:,ith),gmatprefactor, tmatsph(:,ith),use_sratrick)
- END IF
+
+ END DO !lm1
-!c calculate the tmat and wavefunctions
- rllleft(:,:,:,ith)=czero
- sllleft(:,:,:,ith)=czero
+ deallocate(ls_l)
-!c left solutions
-! notice that exchange the order of left and right hankel/bessel functions
- tmattemp=czero
- CALL rllsll(rpan_intervall,rnew,vnspll(:,:,:,ith), &
- rllleft(:,:,:,ith),sllleft(:,:,:,ith),tmattemp, &
- ncheb,npan_tot,lmmaxso,nvec*lmmaxso,4*(lmax+1), &
- irmdnew,nsra,jlk_index,hlk2(:,:,ith),jlk2(:,:,ith), &
- hlk(:,:,ith),jlk(:,:,ith), gmatprefactor,'1','1',use_sratrick)
- IF (nsra == 2) THEN
- rllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)= &
- rllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)/cvlight
- sllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)= &
- sllleft(lmmaxso+1:nvec*lmmaxso,:,:,ith)/cvlight
- END IF
- DO iq = 1,nqdos ! qdos
- den(:,ie,:,iq)=czero
-! read in gf
-! irec = iq + nqdos * (ie-1) + nqdos * ielast * (i1-1) ! qdos
-!!$noomp critical
-! READ(69,REC=irec) gmat0
-!!$noomp end critical
-
- GMAT0 = gmatn(:,:,ie)
-! rotate gmat from global frame to local frame
- CALL rotatematrix(gmat0,theta,phi,lmmaxd,1)
-
- DO lm1=1,lmmaxso
- DO lm2=1,lmmaxso
- gmatll(lm1,lm2,ie)=gmat0(lm1,lm2)
- END DO
+END DO !rl=0,lmax
+
+
+END SUBROUTINE spin_orbit_compl
+
+
+SUBROUTINE beshank(hl,jl,z,lmax)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-19 Time: 12:22:05
+
+!-----------------------------------------------------------------------
+! calculates spherical bessel, hankel and neumann functions
+! for the orders lmin .le. l .le. lmax.
+! For |z| .lt. l+1 the taylor expansions of jl and nl are used.
+! For |z| .ge. l+1 the explicit expressions for hl(+), hl(-) are used.
+!-----------------------------------------------------------------------
+! .. Parameters ..
+DOUBLE COMPLEX ci
+PARAMETER (ci= (0.0D0,1.0D0))
+! ..
+! .. Scalar Arguments ..
+DOUBLE COMPLEX z
+INTEGER :: lmax
+! ..
+! .. Array Arguments ..
+DOUBLE COMPLEX hl(0:lmax),jl(0:lmax),nl(0:lmax)
+! ..
+! .. Local Scalars ..
+DOUBLE COMPLEX termj,termn,z2,zj,zn
+DOUBLE PRECISION :: rl,rn,rnm
+INTEGER :: l,m,n
+! ..
+! .. Intrinsic Functions ..
+INTRINSIC CDABS,EXP
+! ..
+zj = 1.d0
+zn = 1.d0
+z2 = z*z
+IF (CDABS(z) < lmax+1.d0) THEN
+ DO l = 0,lmax
+ rl = l + l
+ termj = -0.5D0/ (rl+3.d0)*z2
+ termn = 0.5D0/ (rl-1.d0)*z2
+ jl(l) = 1.d0
+ nl(l) = 1.d0
+ DO n = 2,25
+ jl(l) = jl(l) + termj
+ nl(l) = nl(l) + termn
+ rn = n + n
+ termj = -termj/ (rl+rn+1.d0)/rn*z2
+ termn = termn/ (rl-rn+1.d0)/rn*z2
END DO
-! calculate density
- CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
- df,cleb,icleb,iend, &
- irmdnew,thetasnew,ifunm,imt1,lmsp, &
- rll(:,:,:,ith), rllleft(:,:,:,ith),sllleft(:,:,:,ith), &
- cden(:,:,:,ith),cdenlm(:,:,:,ith), &
- cdenns(:,:,ith),rho2nsc_loop(:,:,:,ie),0, &
- lmaxd)
-
- DO jspin=1,4
-
- DO lm1 = 0,lmax
- cdentemp(:,ith)=czero
- dentemp=czero
- DO ir=1,irmdnew
- cdentemp(ir,ith)=cden(ir,lm1,jspin,ith)
- END DO
- CALL intcheb_cell(cdentemp(:,ith),dentemp, &
- rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
- rho2(jspin)=dentemp
- rho2int(jspin)=rho2int(jspin)+rho2(jspin)*df
- IF (jspin <= 2) THEN
- den(lm1,ie,jspin,iq)=rho2(jspin)
- END IF
- END DO
-
- IF (jspin <= 2) THEN
- DO lm1 = 1,lmmaxd
- cdentemp(:,ith)=czero
- dentemp=czero
- DO ir=1,irmdnew
- cdentemp(ir,ith)=cdenlm(ir,lm1,jspin,ith)
- END DO
- CALL intcheb_cell(cdentemp(:,ith),dentemp, &
- rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
- denlm(lm1,ie,jspin,iq)=dentemp
- END DO
- cdentemp(:,ith)=czero
- dentemp=czero
- DO ir=1,irmdnew
- cdentemp(ir,ith)=cdenns(ir,jspin,ith)
- END DO
- CALL intcheb_cell(cdentemp(:,ith),dentemp, &
- rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
- den(lmaxd1,ie,jspin,iq)=dentemp
- rho2int(jspin)=rho2int(jspin)+den(lmaxd1,ie,jspin,iq)*df
- END IF
- END DO ! JSPIN
+ jl(l) = jl(l)*zj
+ nl(l) = -nl(l)*zn/z
+ hl(l) = jl(l) + nl(l)*ci
- DO jspin=1,4
- IF (jspin <= 2) THEN
- DO lm1=0,lmaxd1
- espv(lm1,jspin)=espv(lm1,jspin)+ &
- DIMAG( eryd * den(lm1,ie,jspin,iq) * df )
- END DO
- END IF
+ zj = zj*z/ (rl+3.d0)
+ zn = zn/z* (rl+1.d0)
+ END DO
+END IF
+
+DO l = 0,lmax
+ IF (CDABS(z) >= l+1.d0) THEN
+ hl(l) = 0.d0
+ nl(l) = 0.d0
+ rnm = 1.d0
+ DO m = 0,l
+ hl(l) = hl(l) + rnm/ (-ci* (z+z))**m
+ nl(l) = nl(l) + rnm/ (ci* (z+z))**m
+ rnm = rnm* (l*l+l-m*m-m)/ (m+1.d0)
END DO
- END DO ! IQ = 1,NQDOS
-!END DO
+ hl(l) = hl(l)* (-ci)**l*EXP(ci*z)/ (ci*z)
+ nl(l) = nl(l)*ci**l*EXP(-ci*z)/ (-ci*z)
+ jl(l) = (hl(l)+nl(l))*0.5D0
+ nl(l) = (hl(l)-jl(l))/ci
+ END IF
+END DO
-! get charge at the Fermi energy (IELAST)
+RETURN
-IF (ie == ielast.AND.ldorhoef) THEN
- CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
- cone,cleb,icleb,iend, &
- irmdnew,thetasnew,ifunm,imt1,lmsp, &
- rll(:,:,:,ith), rllleft(:,:,:,ith),sllleft(:,:,:,ith), &
- cden(:,:,:,ith),cdenlm(:,:,:,ith), &
- cdenns(:,:,ith),r2nefc_loop(:,:,:,ith),0, &
- lmaxd)
-END IF
+END SUBROUTINE
+SUBROUTINE beshank_smallcomp(hl,jl,zval,tau,eryd,lmax)
+IMPLICIT NONE
+!-----------------------------------------------------------------------
+! takes the spherical bessel etc functions stored in an array up to LMAX
+! array entries from LMAX+1 to 2*LMAX are assumed to be empty
+! these values are filled with the potential-free solution of the
+! SRA-equations
+!-----------------------------------------------------------------------
+DOUBLE COMPLEX hl(0:2*(lmax+1)-1), jl(0:2*(lmax+1)-1), &
+ nl(0:2*(lmax+1)-1)
+DOUBLE PRECISION :: cvlight
+PARAMETER (cvlight=274.0720442D0)
+DOUBLE COMPLEX zval
+DOUBLE COMPLEX eryd
+DOUBLE PRECISION :: tau
+INTEGER :: lmax
-! get orbital moment
-DO iorb=1,3
- CALL rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll(:,:,ie),ek, &
- cone,cleb,icleb,iend, &
- irmdnew,thetasnew,ifunm,imt1,lmsp, &
- rll(:,:,:,ith), rllleft(:,:,:,ith),sllleft(:,:,:,ith), &
- cden(:,:,:,ith),cdenlm(:,:,:,ith), &
- cdenns(:,:,ith),r2orbc(:,:,:,ith),iorb, &
- lmaxd)
- DO jspin=1,4
- IF (jspin <= 2) THEN
- DO lm1=0,lmax
- cdentemp(:,ith)=czero
- dentemp=czero
- DO ir=1,irmdnew
- cdentemp(ir,ith)=cden(ir,lm1,jspin,ith)
- END DO
- CALL intcheb_cell(cdentemp(:,ith),dentemp,rpan_intervall, &
- ipan_intervall,npan_tot,ncheb,irmdnew)
- rho2(jspin)=dentemp
- muorb(lm1,jspin)=muorb(lm1,jspin)-DIMAG(rho2(jspin)*df)
- denorbmom(iorb)=denorbmom(iorb)-DIMAG(rho2(jspin)*df)
- denorbmomsp(jspin,iorb)=denorbmomsp(jspin,iorb)- DIMAG(rho2(jspin)*df)
- denorbmomlm(lm1,iorb)=denorbmomlm(lm1,iorb)- DIMAG(rho2(jspin)*df)
- cdentemp(:,ith)=czero
- DO ir=1,irmdnew
- cdentemp(ir,ith)=cdenns(ir,jspin,ith)
- END DO
- CALL intcheb_cell(cdentemp(:,ith),temp1, &
- rpan_intervall,ipan_intervall,npan_tot,ncheb,irmdnew)
- denorbmomns(iorb)=denorbmomns(iorb)-DIMAG(temp1*df)
- END DO
- END IF
- END DO
-END DO ! IORB
-END DO ! IE loop
+! DOUBLE PRECISION CVLIGHT
+DOUBLE COMPLEX prefac
+INTEGER :: il,il2
-#ifdef CPP_OMP
-!$omp end parallel do
-#endif
-! omp: move sum from rhooutnew here after parallel calculation
-DO ir=1,irmdnew
- DO lm1=1,lmpotd
- DO jspin=1,4
- DO ie=1,ielast
- rho2nsc(ir,lm1,jspin) = rho2nsc(ir,lm1,jspin) + &
- rho2nsc_loop(ir,lm1,jspin,ie)
- END DO
- END DO
- END DO
-END DO
-! omp: don't forget to do the same with density at fermi energy:
-DO ith=0,nth-1
- r2nefc(:,:,:) = r2nefc(:,:,:) + r2nefc_loop(:,:,:,ith)
+
+prefac = 1.0D0 / (1.0D0+eryd/cvlight**2) / tau !/cvlight !last cvlight for small component test
+
+il=0
+il2=il+lmax+1
+nl(il2)=prefac * (zval* (-nl(il+1)) )
+jl(il2)=prefac * (zval* (-jl(il+1)) )
+! HL(IL2)=JL(IL2)+ CI*NL(IL2)
+hl(il2)=prefac * (zval* (-hl(il+1)) )
+! write(*,'(5000E)') tau,HL(IL2),JL(IL2)+ (0.0D0,1.0D0)*NL(IL2)
+! write(*,'(5000E)') tau,HL(0),JL(0)+ (0.0D0,1.0D0)*NL(0)
+
+prefac = 1.0D0 / (1.0D0+eryd/cvlight**2) / tau !/cvlight !last cvlight for small component test
+
+DO il=1,lmax
+ il2=il+lmax+1
+ nl(il2)=prefac * ( zval * nl(il-1)-(il+1)*nl(il) )
+ jl(il2)=prefac * ( zval * jl(il-1)-(il+1)*jl(il) )
+! HL(IL2)=JL(IL2)+ CI*NL(IL2)
+ hl(il2)=prefac * ( zval * hl(il-1)-(il+1)*hl(il) )
+! HL(IL2)=PREFAC * ( ZVAL * HL(IL-1)-(IL+1)*HL(IL) )
+! write(*,'(5000E)') tau,HL(IL2),JL(IL2)+ (0.0D0,1.0D0)*NL(IL2)
END DO
-! omp: moved write-out of dos files out of parallel energy loop
-! Write out qdos and lm-dos: ! lm-dos
-!DO ie=1,ielast ! lm-dos
-! DO iq=1,nqdos ! lm-dos
-! IF ((iq == 1).AND.(ie == 1)) THEN ! lm-dos
-! OPEN(29, ! lm-dos &
-! FILE="lmdos."//CHAR(48+i1/10)//CHAR(48+MOD(i1,10))//"."// ! lm-dos &
-! CHAR(48+1)//".dat") ! lm-dos
-! WRITE (29,*) ' ' ! lm-dos
-! WRITE (29,8600) '# ISPIN=',1,' I1=',i1 ! lm-dos
-! OPEN(30, ! lm-dos &
-! FILE="lmdos."//CHAR(48+i1/10)//CHAR(48+MOD(i1,10))//"."// ! lm-dos &
-! CHAR(48+2)//".dat") ! lm-dos
-! WRITE (30,*) ' ' ! lm-dos
-! WRITE (30,8600) '# ISPIN=',2,' I1=',i1 ! lm-dos
-! END IF ! lm-dos
-
-! IF (opt('qdos ')) THEN ! qdos ruess
-! IF ((iq == 1).AND.(ie == 1)) THEN ! qdos ruess
-! OPEN(31, ! qdos ruess &
-! FILE="qdos."//CHAR(48+i1/10)//CHAR(48+MOD(i1,10))//"."// ! qdos ruess &
-! CHAR(48+1)//".dat") ! qdos ruess
-! WRITE (31,*) ' ' ! qdos ruess
-! WRITE (31,8600) '# ISPIN=',1,' I1=',i1 ! qdos ruess
-! WRITE(31,'(7(A,3X))') '# Re(E)','Im(E)','k_x','k_y','k_z',! qdos &
-! 'DEN_tot','DEN_s,p,...' ! qdos
-! OPEN(32, ! qdos ruess &
-! FILE="qdos."//CHAR(48+i1/10)//CHAR(48+MOD(i1,10))//"."// ! qdos ruess &
-! CHAR(48+2)//".dat") ! qdos ruess
-! WRITE (32,*) ' ' ! qdos ruess
-! WRITE (32,8600) '# ISPIN=',2,' I1=',i1 ! qdos ruess
-! WRITE(32,'(7A)') '# Re(E)','Im(E)','k_x','k_y','k_z', ! qdos &
-! 'DEN_tot','DEN_s,p,...' ! qdos
-
-! 8600 FORMAT (a8,i3,a4,i5) ! qdos ruess
-! END IF ! IQ.EQ.1 ! qdos ruess
-! DO jspin =1,2 ! qdos ruess
-! dentot(jspin) = DCMPLX(0.d0,0.d0) ! qdos ruess
-! DO l1 = 0,lmaxd1 ! qdos ruess
-! dentot(jspin) = dentot(jspin) + den(l1,ie,1,iq) ! qdos ruess
-! END DO ! qdos ruess
-! END DO ! qdos ruess
-! write qdos.nn.s.dat ! qdos ruess
-! and lmdos.nn.s.dat ! qdos ruess
-! WRITE(29,9000) ez(ie),qvec(1,iq),qvec(2,iq),qvec(3,iq), ! qdos ruess &
-! (-DIMAG(denlm(l1,ie,1,iq))/pi,l1=1,lmmaxd) ! qdos ruess
-! WRITE(30,9000) ez(ie),qvec(1,iq),qvec(2,iq),qvec(3,iq), ! qdos ruess &
-! (-DIMAG(denlm(l1,ie,2,iq))/pi,l1=1,lmmaxd) ! qdos ruess
-! WRITE(31,9000) ez(ie),qvec(1,iq),qvec(2,iq),qvec(3,iq), ! qdos ruess &
-! -DIMAG(dentot(1))/pi,(-DIMAG(den(l1,ie,1,iq))/pi,l1=0,lmaxd1)! qdos ruess
-! WRITE(32,9000) ez(ie),qvec(1,iq),qvec(2,iq),qvec(3,iq), ! qdos ruess &
-! -DIMAG(dentot(2))/pi,(-DIMAG(den(l1,ie,2,iq))/pi,l1=0,lmaxd1)! qdos ruess
-! ELSE ! lm-dos
-! WRITE(29,9001) ez(ie), ! lm-dos &
-! (-DIMAG(denlm(l1,ie,1,iq))/pi,l1=1,lmmaxd) ! lm-dos
-! WRITE(30,9001) ez(ie), ! lm-dos &
-! (-DIMAG(denlm(l1,ie,2,iq))/pi,l1=1,lmmaxd) ! lm-dos
-! 9001 FORMAT(30E12.4) ! lm-dos
-! END IF ! OPT('qdos ') ! qdos ruess
-! 9000 FORMAT(5F10.6,40E16.8) ! qdos ruess
-! END DO !IQ
-!END DO !IE
-
-! write
-!IF (opt('lmlm-dos')) THEN ! lmlm-dos
-! DO JSPIN = 1,2 ! lmlm-dos
-! OPEN(90, ! lmlm-dos
-! & FILE="lmlmdos."//char(48+I1/10)//char(48+mod(I1,10))//"."// ! lmlm-dos
-! & char(48+JSPIN)//".dat") ! lmlm-dos
-! DO IE = 1,IELAST ! lmlm-dos
-! DO LM1 = 1,LMMAXD ! lmlm-dos
-! IF (.NOT.(OPT('qdos '))) THEN ! qdos
-! WRITE(90,1000) EZ(IE), ! lmlm-dos
-! & (-DIMAG(GFLLE(LM1+LMSHIFT1(JSPIN), ! lmlm-dos
-! & LM2+LMSHIFT2(JSPIN),IE,1))/PI,LM2 = 1,LMMAXD) ! lmlm-dos
-! ELSE ! qdos
-! DO IQ=1,NQDOS ! qdos
-! WRITE(90,1000) EZ(IE),QVEC(1,IQ),QVEC(2,IQ), ! qdos
-! & QVEC(3,IQ),(-DIMAG(GFLLE(LM1+ ! qdos
-! & LMSHIFT1(JSPIN),LM2+LMSHIFT2(JSPIN), ! qdos
-! & IE,IQ))/PI,LM2 = 1,LMMAXD) ! qdos
-! ENDDO ! IQ=1,NQDOS ! qdos
-! ENDIF ! qdos
-! ENDDO ! lmlm-dos
-! ENDDO !IE ! lmlm-dos
-! CLOSE(90) ! lmlm-dos
-! ENDDO !JSPIN ! lmlm-dos
-! 1000 FORMAT(5F10.6,I3,40E16.8) ! lmlm-dos
-! write gflle to file ! lmlm-dos
-! WRITE(91,REC=i1) gflle ! lmlm-dos
-!END IF ! lmlm-dos
+END SUBROUTINE beshank_smallcomp
-allocate(rhotemp(irmdnew,lmpotd))
-allocate(rhonewtemp(irws,lmpotd))
-DO jspin=1,4
- rhotemp=czero
- rhonewtemp=czero
- DO lm1=1,lmpotd
- DO ir=1,irmdnew
- rhotemp(ir,lm1)=rho2nsc(ir,lm1,jspin)
- END DO
+SUBROUTINE chebint(cslc1,csrc1,slc1sum,c1,n)
+
+! Code converted using TO_F90 by Alan Miller
+! Date: 2016-04-19 Time: 14:23:20
+
+!---------------------------------------------------------------------
+! this subroutine calculates the matrices for the Chebyshev integration
+! as defined on page 141 and 142 of the article:
+! Integral Equation Method for the Continuous Spectrum Radial
+! Schroedinger Equation by R. A. Gonzales et al
+! in Journal of computational physics 134, 134-149 (1997)
+
+! the matrix C is the discrete cosine transform matrix
+! the matrix C1 is the inverse of C
+! the matrix SL is the left spectral integration matrix
+! the matrix SR is the right spectral integration matrix
+! the matrix CSLC1 is the product of C, SL and C1
+! the matrix CSRC1 is the product of C, SR and C1
+!---------------------------------------------------------------------
+! .. Local Scalars ..
+DOUBLE PRECISION :: pi
+INTEGER :: j,k
+! ..
+! .. Local Arrays ..
+DOUBLE PRECISION :: c(0:n,0:n),c1(0:n,0:n),s1(0:n,0:n),s2(0:n,0:n), &
+ sl(0:n,0:n),slc1(0:n,0:n),sr(0:n,0:n), src1(0:n,0:n)
+! ..
+! .. External Subroutines ..
+EXTERNAL dgemm
+! ..
+! .. Intrinsic Functions ..
+INTRINSIC ATAN,COS
+! ..
+! .. Array Arguments ..
+DOUBLE PRECISION :: cslc1(0:n,0:n),csrc1(0:n,0:n),slc1sum(0:n)
+! ..
+! .. Scalar Arguments ..
+INTEGER :: n
+! ..
+pi = 4.d0*ATAN(1.d0)
+!---------------------------------------------------------------------
+! determine the discrete cosine transform matrix from the zeros of the
+! Chebyshev polynomials
+DO j = 0,n
+ DO k = 0,n
+ c(k,j) = COS(((2*k+1)*j*pi)/ (2* (n+1)))
END DO
- CALL cheb2oldgrid(irws,irmdnew,lmpotd,rmesh,ncheb,npan_tot, &
- rpan_intervall,ipan_intervall, rhotemp,rhonewtemp,irmd)
- DO lm1=1,lmpotd
- DO ir=1,irws
- rho2nsnew(ir,lm1,jspin)=rhonewtemp(ir,lm1)
- END DO
+END DO
+!---------------------------------------------------------------------
+! determine the inverse of the discrete cosine transform matrix from
+! the transpose of the discrete cosine transform matrix
+DO j = 0,n
+ DO k = 0,n
+ c1(k,j) = c(j,k)*2.d0/ (n+1)
END DO
-
- rhotemp=czero
- rhonewtemp=czero
- DO lm1=1,lmpotd
- DO ir=1,irmdnew
- rhotemp(ir,lm1)=r2nefc(ir,lm1,jspin)
- END DO
+ c1(0,j) = c1(0,j)*0.5D0
+END DO
+!---------------------------------------------------------------------
+! next to statements can be used to check the products CT*C and C1*C
+CALL dgemm('T','N',n+1,n+1,n+1,1.d0,c,n+1,c,n+1,0.d0,sr,n+1)
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c1,n+1,c,n+1,0.d0,sr,n+1)
+!---------------------------------------------------------------------
+! preparation of the left and right
+! spectral integration matrices SL and SR
+DO j = 0,n
+ DO k = 0,n
+ s1(k,j) = 0.0D0
+ s2(k,j) = 0.0D0
END DO
- CALL cheb2oldgrid(irws,irmdnew,lmpotd,rmesh,ncheb,npan_tot, &
- rpan_intervall,ipan_intervall, rhotemp,rhonewtemp,irmd)
- DO lm1=1,lmpotd
- DO ir=1,irws
- r2nefnew(ir,lm1,jspin)=rhonewtemp(ir,lm1)
- END DO
+END DO
+DO j = 0,n
+ s1(0,j) = (-1.d0)** (j+1)
+ s1(j,j) = 1.d0
+END DO
+DO j = 2,n - 1
+ s2(j,j-1) = 0.5D0/j
+ s2(j,j+1) = -0.5D0/j
+END DO
+s2(n,n-1) = 0.5D0/n
+s2(1,0) = 1.d0
+s2(1,2) = -0.5D0
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,s1,n+1,s2,n+1,0.d0,sl,n+1)
+DO j = 0,n
+ DO k = 0,n
+ s1(k,j) = 0.0D0
END DO
END DO
-deallocate(rhotemp)
-deallocate(rhonewtemp)
-! calculate new THETA and PHI for non-colinear
-!IF (.NOT.test('FIXMOM ')) THEN
-if (angle_fixed == 0) then ! angle not fixed
- rho2ns_temp(1,1)=rho2int(1)
- rho2ns_temp(2,2)=rho2int(2)
- rho2ns_temp(1,2)=rho2int(3)
- rho2ns_temp(2,1)=rho2int(4)
-
- CALL rotatematrix(rho2ns_temp,theta,phi,1,0)
-
- rho2int(1)=rho2ns_temp(1,1)
- rho2int(2)=rho2ns_temp(2,2)
- rho2int(3)=rho2ns_temp(1,2)
- rho2int(4)=rho2ns_temp(2,1)
-
-
- moment(1)=DIMAG(rho2int(3)+rho2int(4))
- moment(2)=-REAL(rho2int(3)-rho2int(4))
- moment(3)=DIMAG(-rho2int(1)+rho2int(2))
+DO j = 0,n
+ s1(j,j) = -1.d0
+ s1(0,j) = 1.d0
+END DO
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,s1,n+1,s2,n+1,0.d0,sr,n+1)
+!---------------------------------------------------------------------
+! determination of the products C*SL*C1 and C*SR*C1
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,sl,n+1,c1,n+1,0.d0,slc1,n+1)
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c,n+1,slc1,n+1,0.d0,cslc1,n+1)
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,sr,n+1,c1,n+1,0.d0,src1,n+1)
+CALL dgemm('N','N',n+1,n+1,n+1,1.d0,c,n+1,src1,n+1,0.d0,csrc1,n+1)
+!---------------------------------------------------------------------
+DO k = 0,n
+ slc1sum(k) = 0.0D0
+ DO j = 0,n
+ slc1sum(k) = slc1sum(k) + slc1(j,k)
+ END DO
+END DO
+RETURN
+END SUBROUTINE
+
+subroutine getLambda(Ncheb,Lambda)
+! set up the Lambda matrix which differentiates the coefficients of an
+! Chebyshev expansion
+implicit none
+integer :: Ncheb
+double precision :: Lambda(0:Ncheb,0:Ncheb)
+!local
+integer icheb,icheb2
+do icheb2=1,Ncheb,2
+ Lambda(0,icheb2)=icheb2
+end do
+do icheb=1,Ncheb
+ do icheb2=icheb+1,Ncheb,2
+ Lambda(icheb,icheb2)=icheb2*2
+ end do
+end do
+end subroutine
- moment_x=moment(1)
- moment_y=moment(2)
- moment_z=moment(3)
-
- totmoment=SQRT(moment(1)**2+moment(2)**2+moment(3)**2)
- totxymoment=SQRT(moment(1)**2+moment(2)**2)
-
- IF (ABS(totxymoment) > 1D-05) THEN
- IF (ABS(moment(3)) < 1D-05) THEN
- thetanew=pi/2D0
- ELSE
- thetanew=ACOS(moment(3)/totmoment)
- END IF
- IF (totxymoment < 1D-05) THEN
- phinew=0D0
- ELSE
- phinew=DATAN2(moment(2),moment(1))
- END IF
- END IF
- ! UPDATE ANGLES
-! phi = phinew
-! theta = thetanew
+subroutine getCinvmatrix(Ncheb,Cinvmatrix)
+! calculates the C**-1 matrix according to:
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+implicit none
+integer, intent(in) :: ncheb
+double precision, intent(out) :: Cinvmatrix(0:Ncheb,0:Ncheb)
+!local
+double precision :: pi
+integer :: icheb1,icheb2
+double precision :: fac
- ! THETANEW=ACOS(MOMENT(3)/TOTMOMENT)
-! PHINEW=DATAN2(MOMENT(2),MOMENT(1))
-! WRITE(6,*) 'moment',moment(1),moment(2),moment(3)
-! WRITE(6,*) 'total moment',TOTMOMENT,TOTXYMOMENT
-! WRITE(6,*) 'angles', thetanew,phinew
-! WRITE(11,*) thetanew,phinew
-! WRITE(12,*) thetanew,phinew
+pi=4d0*datan(1d0)
+fac=1.0D0/(Ncheb+1)
+do icheb1=0,ncheb
+ do icheb2=0,ncheb
+ Cinvmatrix(icheb1,icheb2)=fac*dcos(icheb1*pi*((Ncheb-icheb2)+0.5D0)/(Ncheb+1))
+ end do
+ fac=2.0D0/(Ncheb+1)
+end do
-! Use old angles for rotation
-!if (angle_fixed == 1) then
-! thetanew = theta
-! phinew = phi
-!endif
+end subroutine getCinvmatrix
- CALL rotatevector(rho2nsnew,rho2ns,irws,lmpotd,thetanew,phinew, &
- theta,phi,irmd)
- CALL rotatevector(r2nefnew,r2nef,irws,lmpotd,thetanew,phinew, &
- theta,phi,irmd)
+subroutine getCmatrix(Ncheb,Cmatrix)
+! calculates the C matrix according to:
+! Gonzalez et al, Journal of Computational Physics 134, 134-149 (1997)
+implicit none
+integer, intent(in) :: ncheb
+double precision, intent(out) :: Cmatrix(0:Ncheb,0:Ncheb)
+double precision :: pi
+!local
+integer :: icheb1,icheb2
-else ! angle fixed
+pi=4d0*datan(1d0)
+do icheb1=0,ncheb
+ do icheb2=0,ncheb
+ ! maybe incorrect
+ Cmatrix(icheb2,icheb1)=dcos(icheb1*pi*((Ncheb-icheb2)+0.5D0)/(Ncheb+1))
+ end do
+end do
+end subroutine getCmatrix
- rho2ns_temp(1,1)=rho2int(1)
- rho2ns_temp(2,2)=rho2int(2)
- rho2ns_temp(1,2)=rho2int(3)
- rho2ns_temp(2,1)=rho2int(4)
-
- CALL rotatematrix(rho2ns_temp,theta,phi,1,0)
-
- rho2int(1)=rho2ns_temp(1,1)
- rho2int(2)=rho2ns_temp(2,2)
- rho2int(3)=rho2ns_temp(1,2)
- rho2int(4)=rho2ns_temp(2,1)
- moment(1)=DIMAG(rho2int(3)+rho2int(4))
- moment(2)=-REAL(rho2int(3)-rho2int(4))
- moment(3)=DIMAG(-rho2int(1)+rho2int(2))
- moment_x=moment(1)
- moment_y=moment(2)
- moment_z=moment(3)
-
- rho2ns(:,:,:)=DIMAG(rho2nsnew(:,:,:))
- r2nef(:,:,:)=DIMAG(r2nefnew(:,:,:))
-endif
+subroutine create_Umatrix(theta,phi,lmmax,Umat,Udeggamat)
+implicit none
+!***********************************************************************
+! create the rotation matrix:
+! | cos(theta/2) exp(-i/2 phi) -sin(theta/2) exp(-i/2 phi) |
+! U= | |
+! | sin(theta/2) exp( i/2 phi) cos(theta/2) exp( i/2 phi) |
+!
+! Udegga = transpose(complex conjug ( U ) )
+!***********************************************************************double
+!precision :: phi
+!interface
+double precision,intent(in) :: phi
+double precision,intent(in) :: theta
+integer,intent(in) :: lmmax
+double complex,intent(out) :: Umat(2*lmmax,2*lmmax)
+double complex,intent(out) :: Udeggamat(2*lmmax,2*lmmax)
+!local
+double complex :: Umat11,Umat12,Umat21,Umat22
+double complex :: Udeggamat11,Udeggamat12,Udeggamat21,Udeggamat22
+integer :: ival
+double complex,parameter :: ci=(0.0D0,1.0D0)
+character*25 :: spinmode
-idim = irmd*lmpotd
-CALL dscal(idim,2.d0,rho2ns(1,1,1),1)
-CALL daxpy(idim,-0.5D0,rho2ns(1,1,1),1,rho2ns(1,1,2),1)
-CALL daxpy(idim,1.0D0,rho2ns(1,1,2),1,rho2ns(1,1,1),1)
+spinmode='kkr'
+if (spinmode=='regular') then
+ Umat11 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
+ Umat12 = -sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
+ Umat21 = sin(theta/2.0D0)*exp( ci/2.0D0*phi)
+ Umat22 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
+else if (spinmode=='kkr') then
+ Umat11 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
+ Umat12 = sin(theta/2.0D0)*exp( ci/2.0D0*phi)
+ Umat21 = -sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
+ Umat22 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
+else
+ stop '[create_Umatrix] mode not known'
+end if
-! --> do the same at the Fermi energy
+Umat=(0.0D0,0.0D0)
+do ival=1,lmmax
+ Umat( ival, ival) = Umat11
+ Umat( ival,lmmax+ival) = Umat12
+ Umat(lmmax+ival,ival) = Umat21
+ Umat(lmmax+ival,lmmax+ival) = Umat22
+end do
-CALL dscal(idim,2.d0,r2nef(1,1,1),1)
-CALL daxpy(idim,-0.5D0,r2nef(1,1,1),1,r2nef(1,1,2),1)
-CALL daxpy(idim,1.0D0,r2nef(1,1,2),1,r2nef(1,1,1),1)
+if (spinmode=='regular') then
+Udeggamat11 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
+Udeggamat12 = sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
+Udeggamat21 = -sin(theta/2.0D0)*exp( ci/2.0D0*phi)
+Udeggamat22 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
+else if (spinmode=='kkr') then
+Udeggamat11 = cos(theta/2.0D0)*exp(-ci/2.0D0*phi)
+Udeggamat12 = -sin(theta/2.0D0)*exp( ci/2.0D0*phi)
+Udeggamat21 = sin(theta/2.0D0)*exp(-ci/2.0D0*phi)
+Udeggamat22 = cos(theta/2.0D0)*exp( ci/2.0D0*phi)
+else
+ stop '[create_Umatrix] mode not known'
+end if
-DO lm1=0,lmaxd1
- DO ie=1,iemxd
- DO jspin=1,nspin
- den_out(lm1,ie,jspin) = den(lm1,ie,jspin,1)
- END DO
- END DO
-END DO
-! UPDATE ANGLES
-if (angle_fixed == 0) then
-phi = phinew
-theta = thetanew
-endif
-deallocate(vins)
-deallocate(vnspll0)
-deallocate(vnspll1)
-deallocate(vnspll)
-deallocate(hlk)
-deallocate(jlk)
-deallocate(hlk2)
-deallocate(jlk2)
-deallocate(tmatsph)
-deallocate(rll)
-deallocate(rllleft)
-deallocate(sllleft)
-deallocate(cden)
-deallocate(cdenlm)
-deallocate(cdenns)
-deallocate(rho2nsc,rho2nsc_loop)
-deallocate(rho2nsnew)
-deallocate(r2nefc,r2nefc_loop)
-deallocate(r2nefnew)
-deallocate(r2orbc)
-deallocate(cdentemp)
-deallocate(gflle_part)
-deallocate(gflle)
-deallocate(den,denlm)
-END SUBROUTINE rhovalnew
+Udeggamat=(0.0D0,0.0D0)
+do ival=1,lmmax
+ Udeggamat( ival, ival) = Udeggamat11
+ Udeggamat( ival,lmmax+ival) = Udeggamat12
+ Udeggamat(lmmax+ival,ival) = Udeggamat21
+ Udeggamat(lmmax+ival,lmmax+ival) = Udeggamat22
+end do
-SUBROUTINE rhooutnew(nsra,lmmaxd,lmmaxso,lmax,gmatll,ek, &
- df,cleb,icleb,iend, &
- irmdnew,thetasnew,ifunm,imt1, &
- lmsp,rll,rllleft,sllleft, &
- cden,cdenlm,cdenns,rho2nsc,corbital, &
- lmaxd)
-
-! Code converted using TO_F90 by Alan Miller
-! Date: 2016-04-21 Time: 16:24:21
+end subroutine create_Umatrix
+
+SUBROUTINE spin_orbit_one_l(lmax,l_s)
IMPLICIT NONE
-INTEGER, INTENT(IN) :: nsra
-INTEGER, INTENT(IN) :: lmmaxd
-INTEGER, INTENT(IN) :: lmmaxso
-INTEGER, INTENT(IN) :: lmax
-DOUBLE COMPLEX, INTENT(IN) :: gmatll(:,:)
-DOUBLE COMPLEX, INTENT(IN) :: ek
-!INTEGER, INTENT(IN) :: lmpotd
-DOUBLE COMPLEX, INTENT(IN) :: df
-!INTEGER, INTENT(IN) :: npan_tot
-!INTEGER, INTENT(IN) :: ncheb
-DOUBLE PRECISION, INTENT(IN) :: cleb(:)
-INTEGER, INTENT(IN) :: icleb(:,:)
-INTEGER, INTENT(IN) :: iend
-INTEGER, INTENT(IN) :: irmdnew
-!INTEGER, INTENT(IN) :: nrmaxd
-DOUBLE PRECISION, INTENT(IN) :: thetasnew(:,:)
-INTEGER, INTENT(IN) :: ifunm(:)
-!DOUBLE PRECISION, INTENT(IN) :: rnew(:)
-INTEGER, INTENT(IN) :: imt1
-INTEGER, INTENT(IN) :: lmsp(:)
-DOUBLE COMPLEX, INTENT(IN) :: rll(:,:,:)
-!DOUBLE COMPLEX, INTENT(IN) :: sll(:,:,:)
-DOUBLE COMPLEX, INTENT(IN) :: rllleft(:,:,:)
-DOUBLE COMPLEX, INTENT(IN) :: sllleft(:,:,:)
-DOUBLE COMPLEX, INTENT(OUT) :: cden(:,0:,:)
-DOUBLE COMPLEX, INTENT(OUT) :: cdenlm(:,:,:)
-DOUBLE COMPLEX, INTENT(OUT) :: cdenns(:,:)
-DOUBLE COMPLEX, INTENT(OUT) :: rho2nsc(:,:,:)
-INTEGER, INTENT(IN) :: corbital
-!DOUBLE COMPLEX, INTENT(OUT) :: gflle_part(:,:)
-!DOUBLE PRECISION, INTENT(IN) :: rpan_intervall(:)
-!INTEGER, INTENT(IN) :: ipan_intervall(:)
-INTEGER, INTENT(IN) :: lmaxd ! new parameter
+INTEGER, INTENT(IN) :: lmax
+DOUBLE COMPLEX, INTENT(OUT) :: l_s((2*lmax+1)*2,(2*lmax+1)*2)
+! ************************************************************************
+! in this subroutine the matrix L*S is calculated for the basis of
+! real spherical harmonics
-!INCLUDE 'inc.p'
+! schematically it has the form
+! ( -L_z L_+ )
+! ( L_- L_z )
-DOUBLE COMPLEX, PARAMETER :: czero=(0D0,0D0)
-DOUBLE COMPLEX, PARAMETER :: cone=(1D0,0D0)
-DOUBLE COMPLEX cltdf
-INTEGER :: ir,jspin,lm1,lm2,lm3,m1,l1,j,ifun
-DOUBLE PRECISION :: c0ll
-DOUBLE COMPLEX, allocatable :: wr(:,:,:),qnsi(:,:),pnsi(:,:), &
- cwr(:) ! lmlm-dos
-INTEGER :: lmshift1(4),lmshift2(4)
-DOUBLE COMPLEX, allocatable :: loperator(:,:,:)
-LOGICAL :: test,opt
-EXTERNAL test,opt
-allocate(wr(lmmaxso,lmmaxso,irmdnew))
-allocate(cwr(irmdnew))
-allocate(qnsi(lmmaxso,lmmaxso))
-allocate(pnsi(lmmaxso,lmmaxso))
-allocate(loperator(lmmaxso,lmmaxso,3))
+! local variables
+INTEGER :: i1,i2,i1l
+DOUBLE COMPLEX :: icompl
+DOUBLE COMPLEX,allocatable :: l_min(:,:)
+DOUBLE COMPLEX,allocatable :: l_up(:,:)
+DOUBLE PRECISION :: lfac
-wr=czero
-cwr=czero
-qnsi=czero
-pnsi=czero
-! set LMSHIFT value which is need to construct CDEN
-lmshift1(1)=0
-lmshift1(2)=lmmaxd
-lmshift1(3)=0
-lmshift1(4)=lmmaxd
-lmshift2(1)=0
-lmshift2(2)=lmmaxd
-lmshift2(3)=lmmaxd
-lmshift2(4)=0
-! for orbital moment
-IF (corbital /= 0) THEN
- CALL calc_orbitalmoment(lmaxd,lmmaxso,loperator)
-END IF
-c0ll=1D0/SQRT(16D0*ATAN(1D0))
-cden=czero
-cdenlm=czero
+icompl=(0D0,1D0)
-DO ir = 1,irmdnew
-
- DO lm1 = 1,lmmaxso
- DO lm2 = 1,lmmaxso
- qnsi(lm1,lm2)=sllleft(lm1,lm2,ir)
-! PNSI(LM1,LM2)=RLL(LM1,LM2,IR)
- pnsi(lm1,lm2)=rllleft(lm1,lm2,ir)
- END DO
+
+allocate(l_min(-lmax:lmax,-lmax:lmax))
+allocate(l_up(-lmax:lmax,-lmax:lmax))
+
+! initialize the matrix
+
+DO i1=1,(2*lmax+1)*2
+ DO i2=1,(2*lmax+1)*2
+ l_s(i2,i1)=0D0
END DO
-! CALL ZGEMM('N','N',LMMAXSO,LMMAXSO,LMMAXSO,CONE,PNSI,
-! + LMMAXSO,GMATLL,LMMAXSO,EK,QNSI,LMMAXSO)
- CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
- lmmaxso,gmatll,lmmaxso,ek,qnsi,lmmaxso)
- DO lm1 = 1,lmmaxso
- DO lm2 = 1,lmmaxso
- pnsi(lm1,lm2)=rll(lm1,lm2,ir)
- END DO
+END DO
+
+DO i1=-lmax,lmax
+ DO i2=-lmax,lmax
+ l_min(i2,i1)=0D0
+ l_up(i2,i1)=0D0
END DO
- CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
- lmmaxso,qnsi,lmmaxso,czero,wr(1,1,ir),lmmaxso)
+END DO
+
+! fill the second and the forth quadrant with L_z
+! (-L_z,respectively)
+
+
+DO i1=1,2*lmax+1
+ i1l=i1-lmax-1 ! the value of m (varies from -l to +l)
+ i2=2*lmax+1-(i1-1)
- IF (nsra == 2) THEN
- DO lm1 = 1,lmmaxso
- DO lm2 = 1,lmmaxso
-! QNSI(LM1,LM2)=SLLLEFT(LM1+LMMAXSO,LM2,IR)
- qnsi(lm1,lm2)=-sllleft(lm1+lmmaxso,lm2,ir)
-! PNSI(LM1,LM2)=RLLLEFT(LM1+LMMAXSO,LM2,IR)
- pnsi(lm1,lm2)=-rllleft(lm1+lmmaxso,lm2,ir)
- END DO
- END DO
-! CALL ZGEMM('N','N',LMMAXSO,LMMAXSO,LMMAXSO,CONE,PNSI,
-! + LMMAXSO,GMATLL,LMMAXSO,EK,QNSI,LMMAXSO)
- CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
- lmmaxso,gmatll,lmmaxso,ek,qnsi,lmmaxso)
- DO lm1 = 1,lmmaxso
- DO lm2 = 1,lmmaxso
- pnsi(lm1,lm2)=rll(lm1+lmmaxso,lm2,ir)
- END DO
- END DO
- CALL zgemm('N','T',lmmaxso,lmmaxso,lmmaxso,cone,pnsi, &
- lmmaxso,qnsi,lmmaxso,cone,wr(1,1,ir),lmmaxso)
- END IF
+! L_S(i2,i1)=icompl*i1l
+ l_s(i2,i1)=-icompl*i1l
-! for orbital moment
- IF (corbital /= 0) THEN
- CALL zgemm('N','N',lmmaxso,lmmaxso,lmmaxso,cone, &
- loperator(1,1,corbital),lmmaxso,wr(1,1,ir), lmmaxso,czero,pnsi,lmmaxso)
- DO lm1=1,lmmaxso
- DO lm2=1,lmmaxso
- wr(lm1,lm2,ir)=pnsi(lm1,lm2)
- END DO
- END DO
- END IF
+END DO
+
+DO i1=2*lmax+2,(2*lmax+1)*2
+ i1l=i1-lmax-1-(2*lmax+1) ! the value of m (varies from -l to +l)
+ i2=(2*lmax+1)*2-(i1-(2*lmax+2))
- DO jspin = 1,4
- DO lm1 = 1,lmmaxd
- DO lm2 = 1,lm1-1
- wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)= &
- wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)+ &
- wr(lm2+lmshift1(jspin),lm1+lmshift2(jspin),ir)
- END DO
- END DO
- END DO ! JSPIN
+! L_S(i2,i1)=-icompl*i1l
+ l_s(i2,i1)=icompl*i1l
-END DO !IR
+END DO
+
+! implement now L_- in the third quadrant
+IF (lmax>0) THEN
+
+ lfac=SQRT(lmax*(lmax+1D0))/SQRT(2D0)
+ l_min(0,-1)=-icompl*lfac
+! l_min(0,-1)=icompl*lfac
+ l_min(0,1)=lfac
+ l_min(-1,0)=icompl*lfac
+ l_min(1,0)=-lfac
+
+ IF (lmax > 1) THEN
+
+ DO i1=2,lmax
+
+ lfac=0.5D0*SQRT(lmax*(lmax+1D0)-i1*(i1-1D0))
+ l_min(-i1,-i1+1)=-lfac
+ l_min(-i1,i1-1)=icompl*lfac
+ l_min(i1,-i1+1)=-icompl*lfac
+ l_min(i1,i1-1)=-lfac
+
+ lfac=0.5D0*SQRT(lmax*(lmax+1D0)-(i1-1)*(i1))
+ l_min(-i1+1,-i1)=lfac
+ l_min(-i1+1,i1)=icompl*lfac
+ l_min(i1-1,-i1)=-icompl*lfac
+ l_min(i1-1,i1)=lfac
+
+ END DO
+
+ END IF
+END IF
-!IF (opt('lmlm-dos')) THEN ! lmlm-dos
-! Integrate only up to muffin-tin radius. ! lmlm-dos
-! gflle_part = czero ! lmlm-dos
-! DO lm2 = 1,lmmaxso ! lmlm-dos
-! DO lm1 = 1,lmmaxso ! lmlm-dos
-! For integration up to MT radius do this: ! lmlm-dos
-! CWR(1:IMT1) = WR(LM1,LM2,1:IMT1) ! lmlm-dos
-! CWR(IMT1+1:IRMDNEW) = CZERO ! lmlm-dos
-! CALL INTCHEB_CELL(CWR,GFLLE_PART(LM1,LM2),RPAN_INTERVALL, ! lmlm-dos
-! + IPAN_INTERVALL,NPAN_TOT,NCHEB,IRMDNEW) ! lmlm-dos
-! For full cell integration replace loop content with this: ! lmlm-dos
-! cwr(1:irmdnew) = wr(lm1,lm2,1:irmdnew) ! lmlm-dos
-! DO ir=imt1+1,irmdnew ! lmlm-dos
-! cwr(ir) = cwr(ir)*thetasnew(ir,1)*c0ll ! lmlm-dos
-! END DO ! lmlm-dos
-! CALL intcheb_cell(cwr,gflle_part(lm1,lm2),rpan_intervall, & ! lmlm-dos &
-! ipan_intervall,npan_tot,ncheb,irmdnew) ! lmlm-dos
-! END DO ! lmlm-dos
-! END DO ! lmlm-dos
-!END IF ! OPT('lmlm-dos')
-
-
-! DO IR = 1,IRMDNEW
-! DO JSPIN = 1,4
-! DO LM1 = 1,LMMAXD
-! DO LM2 = 1,LM1-1
-! WR(LM1+LMSHIFT1(JSPIN),LM2+LMSHIFT2(JSPIN),IR)=
-! + WR(LM1+LMSHIFT1(JSPIN),LM2+LMSHIFT2(JSPIN),IR)+
-! + WR(LM2+LMSHIFT1(JSPIN),LM1+LMSHIFT2(JSPIN),IR)
-! ENDDO
-! ENDDO
-! ENDDO ! JSPIN
-! ENDDO !IR
+DO i1=-lmax,lmax
+ DO i2=-lmax,lmax
+ l_s(i2+3*lmax+2,i1+lmax+1)=l_min(i1,i2)
+ END DO
+END DO
-! first calculate the spherical symmetric contribution
+! implement now L_+ in the quadrant
-DO l1 = 0,lmax
+IF (lmax>0) THEN
- DO m1 = -l1,l1
- lm1 = l1*(l1+1)+m1+1
- DO ir = 1,irmdnew
- DO jspin=1,4
- cden(ir,l1,jspin) = cden(ir,l1,jspin)+ &
- wr(lm1+lmshift1(jspin),lm1+lmshift2(jspin),ir)
- cdenlm(ir,lm1,jspin) = wr(lm1+lmshift1(jspin),lm1+lmshift2(jspin),ir)
- END DO ! JPSIN
- END DO ! IR
- END DO ! M1
+ lfac=SQRT(lmax*(lmax+1D0))/SQRT(2D0)
+ l_up(0,-1)=-icompl*lfac
+ l_up(0,1)=-lfac
+ l_up(-1,0)=icompl*lfac
+ l_up(1,0)=lfac
- DO jspin = 1,4
- DO ir = 1,irmdnew
- rho2nsc(ir,1,jspin) = rho2nsc(ir,1,jspin)+ c0ll*(cden(ir,l1,jspin)*df)
- END DO ! IR
+ IF (lmax > 1) THEN
- DO ir=imt1+1,irmdnew
- cden(ir,l1,jspin) = cden(ir,l1,jspin)*thetasnew(ir,1)*c0ll
+ DO i1=2,lmax
- DO m1 = -l1,l1
- lm1 = l1*(l1+1)+m1+1
- cdenlm(ir,lm1,jspin) = cdenlm(ir,lm1,jspin) *thetasnew(ir,1)*c0ll
- END DO ! M1
- END DO ! IR
+ lfac=0.5D0*SQRT(lmax*(lmax+1D0)-i1*(i1-1D0))
+ l_up(-i1,-i1+1)=lfac
+ l_up(-i1,i1-1)=icompl*lfac
+ l_up(i1,-i1+1)=-icompl*lfac
+ l_up(i1,i1-1)=lfac
+
+ lfac=0.5D0*SQRT(lmax*(lmax+1D0)-(i1-1)*(i1))
+ l_up(-i1+1,-i1)=-lfac
+ l_up(-i1+1,i1)=icompl*lfac
+ l_up(i1-1,-i1)=-icompl*lfac
+ l_up(i1-1,i1)=-lfac
+
+ END DO
- END DO ! JSPIN
-
-END DO ! L1
+ END IF
+END IF
-cdenns=czero
-DO j = 1,iend
- lm1 = icleb(j,1)
- lm2 = icleb(j,2)
- lm3 = icleb(j,3)
- cltdf = df*cleb(j)
-
- DO jspin = 1,4
- DO ir = 1,irmdnew
- rho2nsc(ir,lm3,jspin) = rho2nsc(ir,lm3,jspin) + &
- (cltdf*wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir))
- END DO
-
- IF (lmsp(lm3) > 0) THEN
- ifun = ifunm(lm3)
- DO ir=imt1+1,irmdnew
- cdenns(ir,jspin) = cdenns(ir,jspin)+ &
- cleb(j)*wr(lm1+lmshift1(jspin),lm2+lmshift2(jspin),ir)* &
- thetasnew(ir,ifun)
- END DO
- END IF
- END DO ! JSPIN
-END DO ! J
+DO i1=-lmax,lmax
+ DO i2=-lmax,lmax
+ l_s(i2+lmax+1,i1+3*lmax+2)=l_up(i1,i2)
+ END DO
+END DO
-deallocate(wr)
-deallocate(cwr)
-deallocate(qnsi)
-deallocate(pnsi)
-END SUBROUTINE rhooutnew
+
+deallocate(l_min)
+deallocate(l_up)
+
+
+END SUBROUTINE spin_orbit_one_l
subroutine intcheb_cell(cden,den,rpan_intervall,ipan_intervall, &
@@ -6177,7 +5133,6 @@ do ir=1,nrmesh
end do
end subroutine getCCmatrix
-
subroutine create_Wmatrix(theta,phi,theta_old,phi_old,lmmax,Wmat1,Wmat2)
implicit none
!***********************************************************************
diff --git a/source/KKRnano/source/PotentialConverter_mod.F90 b/source/KKRnano/source/PotentialConverter_mod.F90
index 546a3ca068fc4f5f32e299bd7878691955e5f848..9fbdf63290127f2c04738060c971f10d8a731bac 100644
--- a/source/KKRnano/source/PotentialConverter_mod.F90
+++ b/source/KKRnano/source/PotentialConverter_mod.F90
@@ -1,8 +1,3 @@
-!--------------------------------------------------------------------------------
-! Copyright (c) 2018 Forschungszentrum Juelich GmbH, Juelich, Germany
-! This file is part of KKRnano and available as free software under the conditions
-! of the MIT license as expressed in the LICENSE file in more detail.
-!--------------------------------------------------------------------------------
module PotentialConverter_mod
!-------------------------------------------------------------------------------
!> Summary: Converts unformatted potential file to the KKRhost formatted potential file format
@@ -52,10 +47,10 @@ module PotentialConverter_mod
call associateBasisAtomMesh(atomdata, mesh)
! show data on stdout
- call represent(mesh, str)
- write(*, '(A)') str
- call represent(atomdata%potential, str)
- write(*, '(A)') str
+! call represent(mesh, str)
+! write(*, '(A)') str
+! call represent(atomdata%potential, str)
+! write(*, '(A)') str
call writeFormattedPotential(Efermi, ALAT, VBC, KXC, atomdata)
@@ -190,7 +185,7 @@ module PotentialConverter_mod
double precision :: rv, sm
integer :: ic, ir, irmin, is, lm, lmnr, lmpot, nr
- integer, parameter :: isave = 1, inew = 1
+ integer, parameter :: isave = 1, inew = 2
double precision, parameter :: qbound = 1.d-10
character(len=24), parameter :: txc(0:3) = [' Morruzi,Janak,Williams', ' von Barth,Hedin ', ' Vosko,Wilk,Nusair ', ' GGA PW91 ']
character(len=*), parameter :: F9000 = "(7a4,6x,' exc:',a24,3x,a10)", &
@@ -236,7 +231,8 @@ module PotentialConverter_mod
enddo ! lm
!---> write a one to mark the end
- if (lmnr < lmpot) write(ifile, fmt=F9060) isave
+! if (lmnr < lmpot) write(ifile, fmt=F9060) isave
+ write(ifile, fmt=F9060) isave
endif
enddo ! is
diff --git a/source/KKRnano/source/ProcessKKRresults_mod.F90 b/source/KKRnano/source/ProcessKKRresults_mod.F90
index 35814f530ed649520e0fa64ccbf9d9576e57909d..43a67fb690211632335f40a3b1cc87a04e3b94c7 100644
--- a/source/KKRnano/source/ProcessKKRresults_mod.F90
+++ b/source/KKRnano/source/ProcessKKRresults_mod.F90
@@ -451,6 +451,7 @@ module ProcessKKRresults_mod
double precision :: chrgNt_local
double precision :: new_fermi
double precision :: CHRGSEMICORE !< total semicore charge over all atoms
+ double precision :: fsemicore_in
integer :: ila, r1fu
integer :: num_local_atoms
@@ -659,7 +660,12 @@ module ProcessKKRresults_mod
! --> Sum up semicore charges from different MPI ranks
call sumChargeSemi_com(CHRGSEMICORE, mp%mySEComm)
! --> Recalculate the semicore contour factor FSEMICORE
- if (mp%isMasterRank) call calcFactorSemi(CHRGSEMICORE, emesh%FSEMICORE, params%fsemicore)
+ if(iter==1) then
+ fsemicore_in = params%fsemicore
+ else
+ fsemicore_in = emesh%FSEMICORE
+ endif
+ if (mp%isMasterRank) call calcFactorSemi(CHRGSEMICORE, emesh%FSEMICORE, fsemicore_in)
endif
emesh%E2 = new_fermi ! Assumes that for every atom the same Fermi correction
@@ -1532,6 +1538,9 @@ module ProcessKKRresults_mod
double precision moment_x !NOCO
double precision moment_y !NOCO
double precision moment_z !NOCO
+ double precision sum_moment_x !NOCO
+ double precision sum_moment_y !NOCO
+ double precision sum_moment_z !NOCO
double precision max_delta_theta !NOCO
double precision max_delta_phi !NOCO
double precision max_delta_angle !NOCO
@@ -1572,6 +1581,9 @@ module ProcessKKRresults_mod
if (korbit == 1) open(14,file='nonco_moment_out.txt',form='formatted') ! NOCO
! moments output
+ sum_moment_x = 0.0d0
+ sum_moment_y = 0.0d0
+ sum_moment_z = 0.0d0
do i1 = 1, natoms
if (npol == 0) then
read(71, rec=i1) qc,catom,charge,ecore,muorb,phi_noco,theta_noco,phi_noco_old,theta_noco_old,angle_fixed, &
@@ -1613,8 +1625,14 @@ module ProcessKKRresults_mod
theta_noco/(2.0D0*PI)*360.0D0, &
phi_noco/(2.0D0*PI)*360.0D0, &
angle_fixed
+ sum_moment_x = sum_moment_x + moment_x
+ sum_moment_y = sum_moment_y + moment_y
+ sum_moment_z = sum_moment_z + moment_z
endif
enddo ! i1
+ if (korbit == 1) then ! NOCO
+ write(14,"(3f12.5)") sum_moment_x, sum_moment_y, sum_moment_z
+ endif
if (korbit == 1) close(13)
if (korbit == 1) close(14)
diff --git a/source/KKRnano/source/RefCluster_mod.F90 b/source/KKRnano/source/RefCluster_mod.F90
index 1199b1157178340a69a0f03d38649215881e3e1f..67ee595f19f29a4d68875eff9d487d71be18be5d 100644
--- a/source/KKRnano/source/RefCluster_mod.F90
+++ b/source/KKRnano/source/RefCluster_mod.F90
@@ -166,7 +166,7 @@ module RefCluster_mod
#ifdef DEBUG
write(*,'(a,2(i0,a),9999(" ",i0))') 'for atom #',source_atom_index,' indn0(1:',self%numn0,') =',self%indn0(:)
- write(*,'(a,3F16.12)') 'rcls(:,1) = ',rcls(1:3,1)
+ write(*,'(a,3F16.12)') 'rcls(:,1) = ',self%rcls(1:3,1)
#endif
! todo: display some statistics
#ifdef DEBUG
diff --git a/source/KKRnano/source/ScatteringCalculation_mod.F90 b/source/KKRnano/source/ScatteringCalculation_mod.F90
index f19794634aa9ae2c7c1e2e70c08b081ed7616744..dbdf267b417f46754e0566a4f24f91ef44ae6375 100644
--- a/source/KKRnano/source/ScatteringCalculation_mod.F90
+++ b/source/KKRnano/source/ScatteringCalculation_mod.F90
@@ -107,7 +107,7 @@ implicit none
integer :: omp_threads !DEBUGGING
logical :: xccpl
double precision :: rMTref
- double precision, allocatable :: rMTs(:)
+ double precision, allocatable :: rMTs(:,:), rMTrefs(:,:)
double complex, allocatable :: tmatLL(:,:,:,:) !< all t-matrices inside the truncation zone
double complex, allocatable :: GmatN_buffer(:,:,:) !< GmatN for all local atoms
@@ -187,9 +187,12 @@ implicit none
enddo
endif
!---------------------------------------------------------
- allocate(rMTs(calc%trunc_zone%naez_trc))
- call distribute(calc%xTable, 1, calc%atomdata_a(:)%rMTref, rMTs) ! communicate the Muffin-Tin radii within the truncation zone
-
+ allocate(rMTs(1,calc%trunc_zone%naez_trc), rMTrefs(1,num_local_atoms))
+ rMTrefs(1,:) = calc%atomdata_a(:)%rMTref
+ ! communicate the Muffin-Tin radii within the truncation zone
+ call distribute(calc%xTable, 1, rMTrefs, rMTs)
+ deallocate(rMTrefs, stat=ist) ! ignore status
+
! IE ====================================================================
! BEGIN do loop over energies (EMPID-parallel)
! IE ====================================================================
@@ -212,7 +215,7 @@ implicit none
do iacls = 1, calc%ref_cluster_a(ila)%nacls
! this calls tref several times with the same parameters if the local atoms are close to each other
! rMTref = kkr(ila)%rMTref(iacls) ! possible if it has been communicated earlier
- rMTref = rMTs(calc%trunc_zone%trunc_atom_idx(calc%ref_cluster_a(ila)%atom(iacls)))
+ rMTref = rMTs(1,calc%trunc_zone%trunc_atom_idx(calc%ref_cluster_a(ila)%atom(iacls)))
call tref(emesh%EZ(IE), params%vref, dims%lmaxd, rMTref, &
kkr(ila)%Tref_ell(:,iacls), kkr(ila)%dTref_ell(:,iacls), derive=(dims%Lly > 0))
!if (dims%korbit == 1) then ! NOCO
@@ -267,7 +270,7 @@ implicit none
noco%theta_noco(i1),noco%phi_noco(i1),1, & !ipot=1 because potential has only one or two entries (spin polarized case)
!dims%lly, &
atomdata%potential%lmpot,atomdata%chebmesh_ptr%irmd_new, &
- kkr(ila)%TmatN(:,:,ispin),params%soc)
+ kkr(ila)%TmatN(:,:,ispin),params%soc,params%enable_quad_prec)
call rotatematrix(kkr(ila)%TmatN(:,:,ispin),noco%theta_noco(i1),noco%phi_noco(i1),lmmaxd,0)
else
@@ -537,7 +540,7 @@ implicit none
enddo ! iorbit
allocate(uTu_sum(lmmaxd_noco,lmmaxd_noco), uT(lmmaxd_noco,lmmaxd_noco))
- ! No symmtetrization is performed in case of a NOCO calculation
+ ! No symmetrization is performed in case of a NOCO calculation
if (korbit == 0) then ! NOCO
!------------------------------------------------- SYMMETRISE TmatN
uTu_sum(:,:) = TmatN(:,:) ! copy, since the 1st entry is the unity operation, start loop from 2
diff --git a/source/KKRnano/source/XC/vxcgga.f90 b/source/KKRnano/source/XC/vxcgga.f90
index 09f78ce9e77052a0bacc705e20976091de57a0c9..936d12d87ee6a002037ffaae095b6d4f3d33f499 100644
--- a/source/KKRnano/source/XC/vxcgga.f90
+++ b/source/KKRnano/source/XC/vxcgga.f90
@@ -42,7 +42,7 @@ subroutine vxcgga(exc,kte,lpot,nspin,rho2ns,v,r,drdi,a, &
implicit none
-double precision, intent(out) :: exc(0:(lpot+1)**2)
+double precision, intent(out) :: exc(0:lpot)
integer, intent(in) :: kte
integer, intent(in) :: lpot
integer, intent(in) :: nspin
diff --git a/source/KKRnano/source/datastructures/ChebMeshData_mod.F90 b/source/KKRnano/source/datastructures/ChebMeshData_mod.F90
index 2ed1cdf358d670c2e6b4e0afbca158a84429ccd6..e16f623bba67909425f4aaab3c9bf947320d45b0 100644
--- a/source/KKRnano/source/datastructures/ChebMeshData_mod.F90
+++ b/source/KKRnano/source/datastructures/ChebMeshData_mod.F90
@@ -335,6 +335,7 @@ subroutine ConstructChebMesh(r_log,npan_log,npan_eq,ncheb, &
!use read_formatted_shapefun_mod, only: shapefunfile
use RadialMeshData_mod, only: RadialMeshData
+double precision :: r_fac
double precision, intent(in) :: r_log
integer, intent(in) :: npan_log
integer, intent(in) :: npan_eq
@@ -350,7 +351,6 @@ double precision, intent(in) :: thetas(:,:)
integer, intent(in) :: nfu
type(RadialMeshData), intent(in) :: radial_mesh
-double precision, parameter :: fac=2d0
integer :: ipotm,ir2,ip, &
ishift,ilogpanshift,ilinpanshift,npan_logtemp,npan_inst,imin,imax,iminnew,imaxnew,lm1
double precision :: rmin,rmax,rval
@@ -378,9 +378,9 @@ ipotm=0
if (ilinpanshift == 1) then
stop 'non-spherical part of the potential needs to be inside the log panel'
end if
-
+ r_fac = (rmax/rmin)**(1.d0/npan_log)
do ip=0,npan_log-ilogpanshift
- rval=(fac**ip-1d0)/(fac**(npan_log-ilogpanshift)-1d0)
+ rval=(r_fac**ip-1d0)/(r_fac**(npan_log-ilogpanshift)-1d0)
rpan_intervall(ip+ishift)= rmin+rval*(rmax-rmin)
ipan_intervall(ip+ishift)= (ip+ishift)*(ncheb+1)
if (ishift == 0.and. rpan_intervall(ip) > radial_mesh%r(radial_mesh%irmin)) then
@@ -674,7 +674,7 @@ end if
! klo and khi now bracket the input value of x.
h=xa(khi)-xa(klo)
! the xa's must be distinct.
-if (h == 0.d0) pause 'bad xa input in splint'
+if (h == 0.d0) STOP 'bad xa input in splint' !! used to be PAUSE
! cubic spline polynomial is now evaluated.
a = (xa(khi)-x)/h
b = (x-xa(klo))/h
diff --git a/source/KKRnano/source/datastructures/InputParamsNew.txt b/source/KKRnano/source/datastructures/InputParamsNew.txt
index a958fde0d48a0f422aa6d32ed56710abffce1a54..bf982f4d39c51feb3a6b81173ce087c2a76a0cc9 100644
--- a/source/KKRnano/source/datastructures/InputParamsNew.txt
+++ b/source/KKRnano/source/datastructures/InputParamsNew.txt
@@ -120,3 +120,5 @@ i npan_eq 30
i ncheb 10
### [NOCO] size of logarithmic panel
d r_log 0.1D0
+### parameter a for exponential radial mesh
+d a_log 0.025D0
diff --git a/source/KKRnano/source/datastructures/InputParams_mod.F90 b/source/KKRnano/source/datastructures/InputParams_mod.F90
index cc2e06fb739ab698796544055bb9ca4fbd85e928..f6ada62cddc1fe9d30330ec53cf2ef793e8c0455 100644
--- a/source/KKRnano/source/datastructures/InputParams_mod.F90
+++ b/source/KKRnano/source/datastructures/InputParams_mod.F90
@@ -76,6 +76,8 @@ module InputParams_mod
integer :: npan_eq
integer :: ncheb
double precision :: r_log
+ double precision :: a_log
+ logical :: enable_quad_prec
endtype ! InputParams
@@ -618,6 +620,24 @@ integer function getValues(filename, self) result(ierror)
destroy_and_return
endif
+ ierror = getValue(cr, "a_log", self%a_log , def=0.025D0)
+ if (ierror == use_default) then
+ write(*,*) "WARNING: Bad/no value given for a_log. Set a_log to 0.025D0"
+ ierror = 0 ! ok, no error
+ elseif (ierror /= 0) then
+ write(*,*) "Bad/no value given for a_log."
+ destroy_and_return
+ endif
+
+ ierror = getValue(cr, "enable_quad_prec", self%enable_quad_prec , def=.false.)
+ if (ierror == use_default) then
+ write(*,*) "WARNING: Bad/no value given for enable_quad_prec. Set enable_quad_prec to .false."
+ ierror = 0 ! ok, no error
+ elseif (ierror /= 0) then
+ write(*,*) "Bad/no value given for enable_quad_prec."
+ destroy_and_return
+ endif
+
write(*,*) "Finished reading information from input.conf"
destroy_and_return
#undef destroy_and_return
diff --git a/source/KKRnano/source/datastructures/RadialMeshData_mod.F90 b/source/KKRnano/source/datastructures/RadialMeshData_mod.F90
index a5084c0df4a380353fe83a41eb3883d2e91388da..355f6e5f4f18bddd6bdbe214fdd8e01c4553d239 100644
--- a/source/KKRnano/source/datastructures/RadialMeshData_mod.F90
+++ b/source/KKRnano/source/datastructures/RadialMeshData_mod.F90
@@ -160,17 +160,18 @@ module RadialMeshData_mod
double precision, intent(in) :: radius_mt
double precision, intent(in) :: a_log
double precision, intent(in) :: b_log
+ double precision :: b_log_local
!double precision, parameter :: A = 0.025d0
integer :: ii
self%A = a_log
- self%B = b_log
- !self%B = radius_mt / (exp(a_log * (imt - 1)) - 1.d0)
+ b_log_local = radius_mt / (exp(a_log * (imt - 1)) - 1.d0)
+ self%B = b_log_local
do ii = 1, imt
- self%r(ii) = b_log * (exp(a_log * (ii - 1)) - 1.d0)
- self%drdi(ii) = a_log * b_log * exp(a_log * (ii - 1))
+ self%r(ii) = b_log_local * (exp(a_log * (ii - 1)) - 1.d0)
+ self%drdi(ii) = a_log * b_log_local * exp(a_log * (ii - 1))
enddo ! ii
self%rmt = radius_MT
diff --git a/source/KKRnano/source/madelung/MadelungCalculator_mod.F90 b/source/KKRnano/source/madelung/MadelungCalculator_mod.F90
index 7eeafff7e4410a7c73d0a01f88c6b23e3cbe17d2..da8839117391f246ce23c1195b0ea09d64268c98 100644
--- a/source/KKRnano/source/madelung/MadelungCalculator_mod.F90
+++ b/source/KKRnano/source/madelung/MadelungCalculator_mod.F90
@@ -886,7 +886,7 @@ module MadelungCalculator_mod
det = determinant3x3_r(a)
if(det == 0.) then
#ifdef DEBUG
- if(o>0) write(o,'(9A)') sym,' invert3x3: determinant = 0.'
+ write(*,'(9A)') ' invert3x3: determinant = 0.'
#endif
inverse = 0.
return
diff --git a/source/KKRnano/source/parallel/KKRnano_Comm_mod.F90 b/source/KKRnano/source/parallel/KKRnano_Comm_mod.F90
index fbe5f4e675d570674d16886078ed881aeee83aeb..76d54bfa3004c6e0b19bcd9a06489ef4740b1396 100644
--- a/source/KKRnano/source/parallel/KKRnano_Comm_mod.F90
+++ b/source/KKRnano/source/parallel/KKRnano_Comm_mod.F90
@@ -79,6 +79,7 @@ module KKRnano_Comm_mod
!> Set the number of OpenMP threads to nthrds.
subroutine setKKRnanoNumThreads(nthrds)
integer, intent(in) :: nthrds
+!$ external :: OMP_SET_NUM_THREADS
if (nthrds > 0) then
!$ call OMP_SET_NUM_THREADS(NTHRDS)
endif ! nthrds > 0
diff --git a/source/KKRnano/source/parallel/comm_patterns_TYPE_mod.F95 b/source/KKRnano/source/parallel/comm_patterns_mod.F95
similarity index 96%
rename from source/KKRnano/source/parallel/comm_patterns_TYPE_mod.F95
rename to source/KKRnano/source/parallel/comm_patterns_mod.F95
index 22580d664d4dfc7b19786a3a1c0538b0e0bc28d7..80d05c52216fc2a3d35304d515df4ce4ab383468 100644
--- a/source/KKRnano/source/parallel/comm_patterns_TYPE_mod.F95
+++ b/source/KKRnano/source/parallel/comm_patterns_mod.F95
@@ -19,9 +19,11 @@
!> Module that implements common communication patterns.
!> Purpose: For use when collective communication is not possible
!> Author: Elias Rabel, 2012
+!> Paul F Baumeister, 2019
!
-!> Change only comm_patterns_T Y P E_mod.F90, then run create_comm_patterns.sh
-!> This creates the files for the different datatypes needed.
+!> The file extension .F95 indicates that sed will be applied to this source file
+!> to replace a missing template feature in Fortran.
+!> Do not use more than one name with _TYPE per line!
!
module comm_patterns_TYPE_mod
implicit none
diff --git a/source/KKRnano/source/parallel/create_comm_patterns.sh b/source/KKRnano/source/parallel/create_comm_patterns.sh
deleted file mode 100755
index 0261e06a4a8293479a6b3a4dd9a19b2491a312d1..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/parallel/create_comm_patterns.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-
-# Create files for different datatypes
-
-sed -e 's/_TYPE/Z/' comm_patterns_TYPE_mod.F95 > comm_patternsZ_mod.F90
-sed -e 's/_TYPE/D/' comm_patterns_TYPE_mod.F95 > comm_patternsD_mod.F90
-# sed -e 's/_TYPE/I/' comm_patterns_TYPE_mod.F95 > comm_patternsI_mod.F90
-sed -e 's/_TYPE/C/' comm_patterns_TYPE_mod.F95 > comm_patternsC_mod.F90
diff --git a/source/KKRnano/source/parallel/create_one_sided_comm.sh b/source/KKRnano/source/parallel/create_one_sided_comm.sh
deleted file mode 100755
index 62b0a2901f446816ec13e906762e3b32384d8385..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/parallel/create_one_sided_comm.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-
-# Create files for different datatypes
-
-sed -e 's/_TYPE/Z/' one_sided_comm_TYPE_mod.F95 > one_sided_commZ_mod.F90
-sed -e 's/_TYPE/D/' one_sided_comm_TYPE_mod.F95 > one_sided_commD_mod.F90
-# sed -e 's/_TYPE/I/' one_sided_comm_TYPE_mod.F95 > one_sided_commI_mod.F90
-# sed -e 's/_TYPE/C/' one_sided_comm_TYPE_mod.F95 > one_sided_commC_mod.F90
diff --git a/source/KKRnano/source/parallel/create_two_sided_comm.sh b/source/KKRnano/source/parallel/create_two_sided_comm.sh
deleted file mode 100755
index af533337d60dfee5f9af49c724f6066d06a58063..0000000000000000000000000000000000000000
--- a/source/KKRnano/source/parallel/create_two_sided_comm.sh
+++ /dev/null
@@ -1,8 +0,0 @@
-#!/bin/sh
-
-# Create files for different datatypes
-
-sed -e 's/_TYPE/Z/' two_sided_comm_TYPE_mod.F95 > two_sided_commZ_mod.F90
-sed -e 's/_TYPE/I/' two_sided_comm_TYPE_mod.F95 > two_sided_commI_mod.F90
-sed -e 's/_TYPE/D/' two_sided_comm_TYPE_mod.F95 > two_sided_commD_mod.F90
-# sed -e 's/_TYPE/C/' two_sided_comm_TYPE_mod.F95 > two_sided_commC_mod.F90
diff --git a/source/KKRnano/source/parallel/one_sided_comm_TYPE_mod.F95 b/source/KKRnano/source/parallel/one_sided_comm_mod.F95
similarity index 97%
rename from source/KKRnano/source/parallel/one_sided_comm_TYPE_mod.F95
rename to source/KKRnano/source/parallel/one_sided_comm_mod.F95
index 2584d40e1fa0989134cdcbe822a0a93fad57274c..62b5dab3ac560a7692eddb47a4a402ca5a2ed98e 100644
--- a/source/KKRnano/source/parallel/one_sided_comm_TYPE_mod.F95
+++ b/source/KKRnano/source/parallel/one_sided_comm_mod.F95
@@ -36,6 +36,12 @@
!>
!> \endverbatim
+!> Note by Paul F Baumeister, 2019
+!
+!> The file extension .F95 indicates that sed will be applied to this source file
+!> to replace a missing template feature in Fortran.
+!> Do not use more than one name with _TYPE per line!
+
#define COMMCHECK(X) if ( (X) /= 0 ) then; write(*,*) "Comm failure", X, __LINE__; STOP; endif
#define CHECK(X) if ( .not. (X) ) then; write(*,*) "FAIL: ", __LINE__; STOP; endif
@@ -209,7 +215,7 @@ endmodule ! one_sided_comm_TYPE_mod
#ifdef TEST_ONE_SIDED_COMM__TYPE__
! a test program - not compiled due to conditional compilation
-program test
+program test_one_sided_comm_TYPE
use ChunkIndex_mod, only: getRankAndLocalIndex
use one_sided_comm_TYPE_mod
implicit none
diff --git a/source/KKRnano/source/parallel/two_sided_comm_TYPE_mod.F95 b/source/KKRnano/source/parallel/two_sided_comm_mod.F95
similarity index 96%
rename from source/KKRnano/source/parallel/two_sided_comm_TYPE_mod.F95
rename to source/KKRnano/source/parallel/two_sided_comm_mod.F95
index 548c2f32755cfc2095eaf5ab9bd58014bae66f09..2f57417df366a91b605c3e1abe8596ad301111e4 100644
--- a/source/KKRnano/source/parallel/two_sided_comm_TYPE_mod.F95
+++ b/source/KKRnano/source/parallel/two_sided_comm_mod.F95
@@ -36,6 +36,12 @@
!>
!> \endverbatim
+!> The file extension .F95 indicates that sed will be applied to this source file
+!> to replace a missing template feature in Fortran.
+!> Do not use more than one name with _TYPE per line!
+
+! #define DEBUG
+
#define NUMBERZ double complex
#define NUMBERMPIZ MPI_DOUBLE_COMPLEX
#define NUMBERC complex
@@ -80,11 +86,12 @@ module two_sided_comm_TYPE_mod
include 'mpif.h' ! only: MPI_STATUS_SIZE, MPI_INTEGER, MPI_REQUEST_NULL
assert( self%comm /= 0 )
-
+
call MPI_Comm_rank(self%comm, myrank, ierr)
allocate(sreq(self%send_n), sstats(MPI_STATUS_SIZE,self%send_n), &
- rreq(self%recv_n), rstats(MPI_STATUS_SIZE,self%recv_n), stat=ist) ! ToDo: catch status
+ rreq(self%recv_n), rstats(MPI_STATUS_SIZE,self%recv_n), stat=ist)
+ if (ist /= 0) call MPI_Abort(self%comm, ist, ierr)
sreq(:) = MPI_REQUEST_NULL
rreq(:) = MPI_REQUEST_NULL
@@ -99,19 +106,19 @@ module two_sided_comm_TYPE_mod
do inz = self%send_start(ipair), self%send_start(ipair + 1) - 1
tag = inz - self%send_start(ipair)
iinp = self%send_index(inz)
- call MPI_Isend(Ginp(:,iinp), ncount, NUMBERMPI_TYPE, rank, tag, self%comm, sreq(inz), ierr)
#ifdef DEBUG
write(*, '(9(a,i0))') "send local _TYPE-element ",iinp,"@",myrank," with tag ",tag," to rank ",rank
#endif
+ call MPI_Isend(Ginp(:,iinp), ncount, NUMBERMPI_TYPE, rank, tag, self%comm, sreq(inz), ierr)
enddo ! inz
do inz = self%recv_start(ipair), self%recv_start(ipair + 1) - 1
tag = inz - self%recv_start(ipair)
iout = self%recv_index(inz)
- call MPI_Irecv(Gout(:,iout), ncount, NUMBERMPI_TYPE, rank, tag, self%comm, rreq(inz), ierr)
#ifdef DEBUG
write(*, '(9(a,i0))') "I (rank ",myrank,") want to receive a _TYPE-element with tag ",tag," from rank ",rank
#endif
+ call MPI_Irecv(Gout(:,iout), ncount, NUMBERMPI_TYPE, rank, tag, self%comm, rreq(inz), ierr)
enddo ! inz
else ! rank /= myrank
@@ -128,7 +135,7 @@ module two_sided_comm_TYPE_mod
write(*, '(9(a,i0))') "copy local _TYPE-element ",iinp,"@",myrank," locally"
#endif
enddo ! inz
-
+
endif ! rank /= myrank
enddo ! ipair
diff --git a/source/KKRnano/source/read_formatted_mod.F90 b/source/KKRnano/source/read_formatted_mod.F90
index 9071135bf174bc74052bb70eebc399c6fed8b000..aef3af8e80a7bcd6af433d7d06cd7eda0f5df872 100644
--- a/source/KKRnano/source/read_formatted_mod.F90
+++ b/source/KKRnano/source/read_formatted_mod.F90
@@ -179,7 +179,7 @@ module read_formatted_mod
blocks%vins = 0.d0
lm1 = 2
- do lm = 2, sb%lmpot
+ do lm = 2, sb%lmpot + 1
if (lm1 /= 1) then
if (sb%isave == 1) then
@@ -192,7 +192,7 @@ module read_formatted_mod
if (lm1 > 1) then
if (lm1 < 1) die_here("potential file is not formatted correctly, lm ="+lm1+"out of range! Atom#"-atom_id)
- if (lm1 > sb%lmpot) die_here("potential file is not formatted correctly, lm ="+lm1-", but lmpot ="+sb%lmpot+" for Atom#"-atom_id)
+! if (lm1 > sb%lmpot) die_here("potential file is not formatted correctly, lm ="+lm1-", but lmpot ="+sb%lmpot+" for Atom#"-atom_id)
read(unit, fmt="(1p,4d20.13)", iostat=ios) blocks%vins(irmin:sb%irt1p,lm1)
if (ios /= 0) die_here("failed to read non-spherical potential array vins(:,"-lm1-")! Atom#"-atom_id)
diff --git a/source/KKRnano/source/read_formatted_shapefun_mod.F90 b/source/KKRnano/source/read_formatted_shapefun_mod.F90
index 0e85244c251230759b57ab65d751ddd0f6a3cf0a..fba14cd063010fe4664b4e074b9e207d1b232e4e 100644
--- a/source/KKRnano/source/read_formatted_shapefun_mod.F90
+++ b/source/KKRnano/source/read_formatted_shapefun_mod.F90
@@ -53,7 +53,7 @@ module read_formatted_shapefun_mod
integer :: icell
double precision :: dummy
- read(unit, fmt="(16i5)") sfile%ncell
+ read(unit, fmt=*) sfile%ncell
read(unit, fmt="(4d20.12)") (dummy, icell=1,sfile%ncell)
@@ -93,7 +93,7 @@ module read_formatted_shapefun_mod
integer :: ifun, lm
- read(unit, fmt="(16i5)") shapef%nfu
+ read(unit, fmt=*) shapef%nfu
allocate(shapef%llmsp(shapef%nfu), shapef%thetas(inter%meshn,shapef%nfu))
diff --git a/source/KKRnano/source/shapefun/Voronoi_mod.F90 b/source/KKRnano/source/shapefun/Voronoi_mod.F90
index 8733571fc95a23c00b631b1c8b61c84b3c22f45d..c41e22e83653a54265618ce3bd3a97c00a133fd0 100644
--- a/source/KKRnano/source/shapefun/Voronoi_mod.F90
+++ b/source/KKRnano/source/shapefun/Voronoi_mod.F90
@@ -576,7 +576,10 @@ module Voronoi_mod
#ifndef NDEBUG
if (sum(abs(p(1:3))) < 1.d-80) die_here('halfspace: a,b,c too small.')
#endif
- half_space = (p(0)*(p(1)*v(1) + p(2)*v(2) + p(3)*v(3)) <= p(0)*p(0))
+! half_space = (p(0)*(p(1)*v(1) + p(2)*v(2) + p(3)*v(3)) <= p(0)*p(0))
+! reintroduced tolerance value 1.d-16, seems to be necessary for large-scale
+! MnGe B20 system (R.Zeller June 2020)
+ half_space = (p(0)*(p(1)*v(1) + p(2)*v(2) + p(3)*v(3)) <= p(0)*p(0) +1.d-16)
endfunction ! halfspace
function normal_plane(v1, tau) result(p)
diff --git a/source/KKRnano/source/wrappers_mod.F90 b/source/KKRnano/source/wrappers_mod.F90
index 91c6bd14291f5d65537c3c60c268a0214b3c81c2..befda5ce87b0a23694a72b4d85b99872a0ecd883 100644
--- a/source/KKRnano/source/wrappers_mod.F90
+++ b/source/KKRnano/source/wrappers_mod.F90
@@ -91,7 +91,7 @@ use Warnings_mod, only: launch_warning
theta_noco,phi_noco,angle_fixed,moment_x,moment_y,moment_z,&
1, & ! ipot=1
den,espv,rho2ns,r2nef, gmatn(:,:,:,1), muorb, & ! just one spin component of gmatn needed
- atomdata%potential%lpot,lmaxd,mesh%irmd,chebmesh%irmd_new,iemxd, params%soc)
+ atomdata%potential%lpot,lmaxd,mesh%irmd,chebmesh%irmd_new,iemxd, params%soc,params%enable_quad_prec)
! calculate correct orbital moment
do ispin=1,nspind
diff --git a/source/voronoi/maindriver12.f b/source/voronoi/maindriver12.f
index afd40002c12e3b05634e8baf9c5cc5e189d27738..e078e05438e2e1dd07befbe353fb33877d8079db 100644
--- a/source/voronoi/maindriver12.f
+++ b/source/voronoi/maindriver12.f
@@ -120,6 +120,8 @@ c
+ ZATOM(NTOTD) ! Nuclear charge
INTEGER ICC, ! center of cluster for output of GF
+ ICLS, NAEZ, ! number of atoms in unit cell
+ + NVAC, ! number of empty cells
+ + NVAC_IT,
+ NATYP, ! number of kinds of atoms in unit cell
+ NCLS, ! number of reference clusters
+ NEMB, ! number of 'embedding' positions
@@ -146,6 +148,8 @@ c
& ROUT_ALL(NTOTD), ! Outer cell-radius per atom
& DISTNN(NAEZD+NIMPD), ! Distance from cell center to nearest-neighbor cell center (2*RMTHLF)
& VOLUME_ALL(NTOTD), ! Volume per atom
+ & VCENTER_ALL(3,NTOTD), ! Center of the voronoi cells
+ & VCENTER_SQSUM,
& A3_ALL(NFACED,NTOTD), ! A3,B3,C3,D3: Defining the faces per atom
& B3_ALL(NFACED,NTOTD),
& C3_ALL(NFACED,NTOTD),
@@ -227,7 +231,7 @@ c
& VOLUMECL(NSHAPED),RWSCL(NSHAPED),RMTCL(NSHAPED)
REAL*8 DX(NTOTD),DY(NTOTD),DZ(NTOTD)
REAL*8 ROUT,RTEST,DLT,CRAD,RX,RY,RZ,MTRADIUS,VTOT,
- & SHAPESHIFT(3,NTOTD)
+ & SHAPESHIFT(3,NTOTD),VCENTER(3)
CHARACTER*256 UIO
INTEGER NATOMS,NSITES,NSHAPE ! Number of atoms, sites, shapes
INTEGER LMAX,KEYPAN,NPOI,NA,IAT,JAT,ICL,N1A,I2,II,ISITE
@@ -270,7 +274,7 @@ c
c -----------------------------------------------------------------------
DATA BBOX/2.0d0,2.0d0,3.0d0/
DATA DLT/0.05d0/ ! Parameter for theta-integration (Gauss-Legendre rule). Usually 0.05
- DATA NPOI/125/ ! Total number of shapefunction points
+ DATA NPOI/555/ ! Total number of shapefunction points
DATA NRAD/10/ ! Muffintinization points
DATA NMIN/7/ ! Minimum number of points in panel
DATA NSMALL/10000/ ! A large number to start (See subr. divpanels)
@@ -320,7 +324,7 @@ c
CALL READINPUT(BRAVAIS,LCARTESIAN,RBASIS,ABASIS,BBASIS,CBASIS,
& DX,DY,DZ,
& ALATC,BLATC,CLATC,
- & IRNS,NAEZ,NEMB,KAOEZ,IRM,ZATOM,SITEAT,
+ & IRNS,NAEZ,NVAC,NEMB,KAOEZ,IRM,ZATOM,SITEAT,
& INS,KSHAPE,
& LMAX,LMMAX,LPOT,
& NATYP,NSPIN,
@@ -357,6 +361,9 @@ c Rationalise basis vectors
X TRIGHT)
ENDIF
c
+ DO NVAC_IT = 1,20
+c the number 20 is an empirical value for the number of iterations used
+c to update the empty-cell positions
CALL CLSGEN_VORONOI(NATYP,NAEZ,NEMB,RR,NR,RBASIS,
& KAOEZ,ZATOM,CLS,NCLS,
& NACLS,ATOM,EZOA,
@@ -364,6 +371,7 @@ c
& ZPERIGHT,TLEFT,TRIGHT,
& RCLS,RMTHLF,RCUTZ,RCUTXY,LINTERFACE,
& ALATC)
+ CLOSE (8)
DISTNN(1:NAEZ) = 2.D0*RMTHLF(1:NAEZ)
@@ -529,12 +537,14 @@ c Therefore, sizefac(0) = 1.0 is defined earlier.
WRITE(6,*) 'Entering VORONOI12 for atom=',IAT
CALL VORONOI12(
> NVEC,RVEC,NVERTD,NFACED,WEIGHT0,WEIGHT,TOLVDIST,TOLAREA,TOLHS,
- < RMT0,ROUT,VOLUME,NFACE,A3,B3,C3,D3,NVERT,XVERT,YVERT,ZVERT)
+ < RMT0,ROUT,VOLUME,NFACE,A3,B3,C3,D3,NVERT,XVERT,YVERT,ZVERT,
+ < VCENTER)
c Now store results in atom-dependent array.
RMT0_ALL(IAT) = RMT0
ROUT_ALL(IAT) = ROUT
VOLUME_ALL(IAT) = VOLUME
+ VCENTER_ALL(:,IAT) = VCENTER(:)
NFACE_ALL(IAT) = NFACE
A3_ALL(:,IAT) = A3(:)
B3_ALL(:,IAT) = B3(:)
@@ -547,6 +557,29 @@ c Now store results in atom-dependent array.
20 ENDDO ! DO 20 IAT = 1,NSITES
+
+ IF(NVAC.GT.0) THEN
+ OPEN(333,file='empty_cell.dat',form='formatted')
+ WRITE(6,FMT='(I6,A)') NVAC,
+ + ' empty cell positions will be updated'
+ VCENTER_SQSUM = 0.0D0
+ DO IAT = 1,NVAC
+ VCENTER_SQSUM = VCENTER_SQSUM + SQRT(VCENTER_ALL(1,IAT)**2+
+ + VCENTER_ALL(2,IAT)**2+VCENTER_ALL(3,IAT)**2)
+c an empirical factor 0.2D0 is used to avoid overshooting of the iterations
+ DO J = 1,3
+ VCENTER_ALL(J,IAT) = VCENTER_ALL(J,IAT)*0.2D0
+ END DO
+ RBASIS(:,IAT) = RBASIS(:,IAT) + VCENTER_ALL(:,IAT)
+ WRITE(6,FMT='(3F16.9)') RBASIS(:,IAT)
+ WRITE(333,FMT='(3F16.9)') RBASIS(:,IAT)
+ END DO
+ WRITE(6,FMT='(F16.9,A)') VCENTER_SQSUM,
+ + ' is a quality measure for the empty cell positions'
+ CLOSE(333)
+ END IF
+ IF(NVAC.EQ.0.OR.ABS(VCENTER_SQSUM).LT.1.D-6) EXIT
+ END DO
c-------------------------------------------------------------------------------
diff --git a/source/voronoi/readinput12.f90 b/source/voronoi/readinput12.f90
index 7a0fe021551af66acee46bc70aa75959c4f16115..e73779ead73adcff5f60ccd00994cdd735832aee 100644
--- a/source/voronoi/readinput12.f90
+++ b/source/voronoi/readinput12.f90
@@ -1,7 +1,7 @@
SUBROUTINE READINPUT(BRAVAIS,LCARTESIAN,RBASIS,ABASIS,BBASIS,CBASIS, &
& DX,DY,DZ, &
& ALATC,BLATC,CLATC, &
- & IRNS,NAEZ,NEMB,KAOEZ,IRM,ZAT,SITEAT, &
+ & IRNS,NAEZ,NVAC,NEMB,KAOEZ,IRM,ZAT,SITEAT, &
& INS,KSHAPE, &
& LMAX,LMMAX,LPOT, &
& NATYP,NSPIN, &
@@ -57,7 +57,7 @@
& KVREL,KWS,KXC,LMAX,LMMAX,LMPOT,LPOT,MD, &
& NATYP,NPNT1,NPNT2,NPNT3,NPOL,NSPIN,INDX,IAT
INTEGER NMIN,NSMALL,NRAD,NFACELIM,NBR
- INTEGER NSTEPS,KMT,NAEZ,NEMB
+ INTEGER NSTEPS,KMT,NAEZ,NVAC,NEMB
INTEGER NINEQ,NEMBZ,NZ,CENTEROFINV(3)
REAL*8 ALATC,BLATC,CLATC
INTEGER MMIN,MMAX,SINN,SOUT,RIN,ROUT
@@ -151,6 +151,13 @@
WRITE(*,*) 'readinput: CARTESIAN=',LCARTESIAN
WRITE(111,*) 'CARTESIAN= ',LCARTESIAN
+ CALL IoInput('NVAC ',UIO,1,7,IER)
+ IF (IER.EQ.0) THEN
+ READ (UNIT=UIO,FMT=*) NVAC
+ WRITE(*,*) 'NVAC=', NVAC
+ ELSE
+ NVAC = 0
+ ENDIF
CALL IoInput('NAEZ ',UIO,1,7,IER)
IF (IER.EQ.0) THEN
diff --git a/source/voronoi/voronoi12.f b/source/voronoi/voronoi12.f
index 4c26d721479e7ae83251b451b7bff0844e9e4bec..35a6b69dd3e611eb9dd7a20d07ebb09be1f255f2 100644
--- a/source/voronoi/voronoi12.f
+++ b/source/voronoi/voronoi12.f
@@ -1,7 +1,8 @@
c***********************************************************************
SUBROUTINE VORONOI12(
> NVEC,RVEC,NVERTMAX,NFACED,WEIGHT0,WEIGHT,TOLVDIST,TOLAREA,TOLHS,
- < RMT,ROUT,VOLUME,NFACE,A3,B3,C3,D3,NVERT,XVERT,YVERT,ZVERT)
+ < RMT,ROUT,VOLUME,NFACE,A3,B3,C3,D3,NVERT,XVERT,YVERT,ZVERT,
+ < VCENTER)
c Given a cluster of atomic positions at RVEC(3,NVEC), this subroutine
c returns information about the Voronoi cell around the origin. It is
c supposed, of course, that the origin corresponds to an atomic position
@@ -73,7 +74,7 @@ c ! and of all others (dimensioned as RVEC).
c Output:
INTEGER NFACE
INTEGER NVERT(*)
- REAL*8 VOLUME
+ REAL*8 VOLUME,VCENTER(3)
REAL*8 A3(NFACED),B3(NFACED),C3(NFACED),D3(NFACED)
REAL*8 XVERT(NVERTMAX,NFACED),YVERT(NVERTMAX,NFACED),
& ZVERT(NVERTMAX,NFACED)
@@ -133,6 +134,9 @@ c origin and r1,r2,r3 the vectors of the 3 other vertices.
c Algorithm requires that the face is a convex polygon with the
c vertices ordered (doesn't matter if they are clock- or anticlockwise).
VOLUME = 0.d0
+ VCENTER(1) = 0.d0
+ VCENTER(2) = 0.d0
+ VCENTER(3) = 0.d0
DO IFACE = 1,NFACE
X1 = XVERT(1,IFACE)
Y1 = YVERT(1,IFACE)
@@ -146,6 +150,9 @@ c vertices ordered (doesn't matter if they are clock- or anticlockwise).
Y3 = YVERT(IVERT+1,IFACE)
Z3 = ZVERT(IVERT+1,IFACE)
TETRVOL = X1*(Y2*Z3-Y3*Z2)+X2*(Y3*Z1-Y1*Z3)+X3*(Y1*Z2-Y2*Z1)
+ VCENTER(1) = VCENTER(1) + 0.25d0*DABS(TETRVOL)*(X1+X2+X3)
+ VCENTER(2) = VCENTER(2) + 0.25d0*DABS(TETRVOL)*(Y1+Y2+Y3)
+ VCENTER(3) = VCENTER(3) + 0.25d0*DABS(TETRVOL)*(Z1+Z2+Z3)
VOLUME = VOLUME + DABS(TETRVOL)
TRIANGLEAREA = 0.5d0 * DSQRT(
& ( X1*Y2 + X2*Y3 + X3*Y1 - Y2*X3 - Y3*X1 - Y1*X2)**2
@@ -157,8 +164,12 @@ c vertices ordered (doesn't matter if they are clock- or anticlockwise).
ENDDO
ENDDO
VOLUME = VOLUME/6.D0
+ VCENTER(1) = VCENTER(1)/VOLUME
+ VCENTER(2) = VCENTER(2)/VOLUME
+ VCENTER(3) = VCENTER(3)/VOLUME
WRITE(6,*) ' Polyhedron properties '
+
WRITE(6,*) ' Number of faces : ',nface
IF (TEST('verb0 ')) THEN
diff --git a/tests/gitlab-ci/build_kkrnano.yml b/tests/gitlab-ci/build_kkrnano.yml
new file mode 100644
index 0000000000000000000000000000000000000000..93c488f1c13cf363a3895cf8cbfbaaab43f61607
--- /dev/null
+++ b/tests/gitlab-ci/build_kkrnano.yml
@@ -0,0 +1,21 @@
+build_kkrnano:intel:hybrid:
+ stage: build_kkrnano
+ tags:
+ - docker-executor
+ script:
+ # compile code
+ - cd source/KKRnano/source && mkdir -p build
+ - make -j4 PLATFORM=ifort SMP=openmp
+ - cp kkr.exe ../regtests/kkr.exe
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/kkr.exe
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-activate-tests
+ - kkrnano-chebyshev-tfQMRgpu
diff --git a/tests/gitlab-ci/run_kkrnano.yml b/tests/gitlab-ci/run_kkrnano.yml
new file mode 100644
index 0000000000000000000000000000000000000000..27b304b87298821a954425f976a7e1961dd174da
--- /dev/null
+++ b/tests/gitlab-ci/run_kkrnano.yml
@@ -0,0 +1,121 @@
+run_kkrnano:intel:Cu1:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_Cu1; cd test_Cu1; ln -s ../* .
+ - ls -la
+ - ls -la ..
+ - python3 ./tests.py Test_copper.test_Cu1_lmax
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_Cu1
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu
+
+run_kkrnano:intel:Cu4:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_Cu4; cd test_Cu4; ln -s ../* .
+ - python3 ./tests.py Test_copper.test_Cu4_lmax
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_Cu4
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu
+
+run_kkrnano:intel:GaN:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_GaN; cd test_GaN; ln -s ../* .
+ - python3 ./tests.py Test_semiconductors.test_GaN
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_GaN
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu
+
+run_kkrnano:intel:Si:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_Si; cd test_Si; ln -s ../* .
+ - python3 ./tests.py Test_semiconductors.test_Si
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_Si
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu
+
+run_kkrnano:intel:ZnO:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_ZnO; cd test_ZnO; ln -s ../* .
+ - python3 ./tests.py Test_semiconductors.test_ZnO
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_ZnO
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu
+
+run_kkrnano:intel:MnGeB20:
+ stage: run_kkrnano
+ tags:
+ - docker-executor
+ script:
+ - cd source/KKRnano/regtests
+ - mkdir -p test_MnGeB20; cd test_MnGeB20; ln -s ../* .
+ - python3 ./tests.py Test_nocosocmaterials.test_MnGeB20
+ artifacts:
+ paths:
+ - source/KKRnano/regtests/test_MnGeB20
+ expire_in: 1 day
+ only:
+ - schedules
+ - triggers
+ - web
+ - master
+ - develop
+ - kkrnano-chebyshev-tfQMRgpu