Millepede-II V04-16-03
pede.f90
Go to the documentation of this file.
1! Code converted using TO_F90 by Alan Miller
2! Date: 2012-03-16 Time: 11:06:00
3
27
262
547
548
802
840
883
885PROGRAM mptwo
886 USE mpmod
887 USE mpdalc
888 USE mptest1, ONLY: nplan,del,dvd
889 USE mptest2, ONLY: nlyr,nmx,nmy,sdevx,sdevy,ntot
890
891 IMPLICIT NONE
892 REAL(mps) :: andf
893 REAL(mps) :: c2ndf
894 REAL(mps) :: deltat
895 REAL(mps) :: diff
896 REAL(mps) :: err
897 REAL(mps) :: gbu
898 REAL(mps) :: gmati
899 REAL(mps) :: rej
900 REAL :: rloop1
901 REAL :: rloop2
902 REAL :: rstext
903 REAL(mps) :: secnd
904 REAL :: rst
905 REAL :: rstp
906 REAL, DIMENSION(2) :: ta
907 INTEGER(mpi) :: i
908 INTEGER(mpi) :: ii
909 INTEGER(mpi) :: iopnmp
910 INTEGER(mpi) :: ix
911 INTEGER(mpi) :: ixv
912 INTEGER(mpi) :: iy
913 INTEGER(mpi) :: k
914 INTEGER(mpi) :: kfl
915 INTEGER(mpi) :: lun
916 INTEGER :: minut
917 INTEGER :: nhour
918 INTEGER(mpi) :: nmxy
919 INTEGER(mpi) :: nrc
920 INTEGER(mpi) :: nsecnd
921 INTEGER(mpi) :: ntsec
922
923 CHARACTER (LEN=24) :: chdate
924 CHARACTER (LEN=24) :: chost
925#ifdef LAPACK64
926 CHARACTER (LEN=6) :: c6
927 INTEGER major, minor, patch
928#endif
929
930 INTEGER(mpl) :: rows
931 INTEGER(mpl) :: cols
932
933 REAL(mpd) :: sums(9)
934 !$ INTEGER(mpi) :: OMP_GET_NUM_PROCS,OMP_GET_MAX_THREADS
935 !$ INTEGER(mpi) :: MXTHRD
936 !$ INTEGER(mpi) :: NPROC
937
938 REAL etime
939
940 SAVE
941 ! ...
942 rstp=etime(ta)
943 CALL fdate(chdate)
944
945 ! millepede monitoring file
946 lunmon=0
947 ! millepede.log file
948 lunlog=8
949 lvllog=1
950 CALL mvopen(lunlog,'millepede.log')
951 CALL getenv('HOSTNAME',chost)
952 IF (chost(1:1) == ' ') CALL getenv('HOST',chost)
953 WRITE(*,*) '($Id: c6be33cb87ef25e4226d5088ec53ebf6d39f4712 $)'
954 iopnmp=0
955 !$ iopnmp=1
956 !$ WRITE(*,*) 'using OpenMP (TM)'
957#ifdef LAPACK64
958 CALL ilaver( major,minor, patch )
959 WRITE(*,110) lapack64, major,minor, patch
960110 FORMAT(' using LAPACK64 with ',(a),', version ',i0,'.',i0,'.',i0)
961#ifdef PARDISO
962 WRITE(*,*) 'using Intel oneMKL PARDISO'
963#endif
964#endif
965#ifdef __GFORTRAN__
966 WRITE(*,111) __gnuc__ , __gnuc_minor__ , __gnuc_patchlevel__
967111 FORMAT(' compiled with gcc ',i0,'.',i0,'.',i0)
968#endif
969#ifdef __PGIC__
970 WRITE(*,111) __pgic__ , __pgic_minor__ , __pgic_patchlevel__
971111 FORMAT(' compiled with pgi ',i0,'.',i0,'.',i0)
972#endif
973 WRITE(*,*) ' '
974 WRITE(*,*) ' < Millepede II-P starting ... ',chdate
975 WRITE(*,*) ' ',chost
976 WRITE(*,*) ' '
977
978 WRITE(8,*) '($Id: c6be33cb87ef25e4226d5088ec53ebf6d39f4712 $)'
979 WRITE(8,*) ' '
980 WRITE(8,*) 'Log-file Millepede II-P ', chdate
981 WRITE(8,*) ' ', chost
982
983 CALL peend(-1,'Still running or crashed')
984 ! read command line and text files
985
986 CALL filetc ! command line and steering file analysis
987 CALL filetx ! read text files
988 ! dummy call for dynamic memory allocation
989 CALL gmpdef(0,nfilb,'dummy call')
990
991 IF (icheck > 0) THEN
992 WRITE(*,*) '!!! Checking input only, no calculation of a solution !!!'
993 WRITE(8,*) '!!! Checking input only, no calculation of a solution !!!'
994 END IF
995 lvllog=mprint ! export print level
996 IF (memdbg > 0) printflagalloc=1 ! debug memory management
997 !$ WRITE(*,*)
998 !$ NPROC=1
999 !$ MXTHRD=1
1000 !$ NPROC=OMP_GET_NUM_PROCS() ! number of processors available
1001 !$ CALL OMP_SET_NUM_THREADS(MTHRD) ! set max number of threads to MTHRD
1002 !$ MXTHRD=OMP_GET_MAX_THREADS() ! get max number of threads back
1003 !$ WRITE(*,*) 'Number of processors available: ', NPROC
1004 !$ WRITE(*,*) 'Maximum number of OpenMP threads: ', MXTHRD
1005 !$ WRITE(*,*) 'Number of threads for processing: ', MTHRD
1006 !$ IF (MXREC.GT.0) MTHRDR=1 ! to get allways the same MXREC records
1007 !$ IF (ICHECK.GT.1) MTHRDR=1 ! to get allways the same order of records
1008 !$ WRITE(*,*) 'Number of threads for reading: ', MTHRDR
1009 !$POMP INST INIT ! start profiling with ompP
1010#ifdef LAPACK64
1011 IF(iopnmp > 0) THEN
1012 CALL getenv('OMP_NUM_THREADS',c6)
1013 ELSE
1014 CALL getenv(lapack64//'_NUM_THREADS',c6)
1015 END IF
1016 IF (c6(1:1) == ' ') THEN
1017 IF(iopnmp > 0) THEN
1018 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty OMP_NUM_THREADS)'
1019 ELSE
1020 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty ',lapack64//'_NUM_THREADS)'
1021 END IF
1022 ELSE
1023 WRITE(*,*) 'Number of threads for LAPACK: ', c6
1024 END IF
1025#endif
1026 cols=mthrd
1027 CALL mpalloc(globalchi2sumd,cols,'fractional part of Chi2 sum')
1028 globalchi2sumd=0.0_mpd
1029 CALL mpalloc(globalchi2sumi,cols,'integer part of Chi2 sum')
1030 globalchi2sumi=0_mpl
1031 CALL mpalloc(globalndfsum,cols,'NDF sum')
1032 globalndfsum=0_mpl
1033 CALL mpalloc(globalndfsumw,cols,'weighted NDF sum')
1034 globalndfsumw=0.0_mpd
1035
1036 IF (ncache < 0) THEN
1037 ncache=25000000*mthrd ! default cache size (100 MB per thread)
1038 ENDIF
1039 rows=6; cols=mthrdr
1040 CALL mpalloc(readbufferinfo,rows,cols,'read buffer header')
1041 ! histogram file
1042 lun=7
1043 CALL mvopen(lun,'millepede.his')
1044 CALL hmplun(lun) ! unit for histograms
1045 CALL gmplun(lun) ! unit for xy data
1046
1047 ! debugging
1048 IF(nrecpr /= 0.OR.nrecp2 /= 0) THEN
1049 CALL mvopen(1,'mpdebug.txt')
1050 END IF
1051
1052 rstext=etime(ta)
1053 times(0)=rstext-rstp ! time for text processing
1054
1055 ! preparation of data sub-arrays
1056
1057 CALL loop1
1058 rloop1=etime(ta)
1059 times(1)=rloop1-rstext ! time for LOOP1
1060
1061 CALL loop2
1062 IF(chicut /= 0.0) THEN
1063 WRITE(8,*) 'Chi square cut equiv 3 st.dev applied ...'
1064 WRITE(8,*) ' in first iteration with factor',chicut
1065 WRITE(8,*) ' in second iteration with factor',chirem
1066 WRITE(8,*) ' (reduced by sqrt in next iterations)'
1067 END IF
1068
1069 IF(lhuber /= 0) THEN
1070 WRITE(8,*) 'Down-weighting of outliers in', lhuber,' iterations'
1071 WRITE(8,*) 'Cut on downweight fraction',dwcut
1072 END IF
1073
1074 rloop2=etime(ta)
1075 times(2)=rloop2-rloop1 ! time for LOOP2
1076
1077 IF(icheck > 0) THEN
1078 CALL prtstat
1079 IF (ncgbe < 0) THEN
1080 CALL peend(5,'Ended without solution (empty constraints)')
1081 ELSE
1082 CALL peend(0,'Ended normally')
1083 END IF
1084 GOTO 99 ! only checking input
1085 END IF
1086
1087 ! use different solution methods
1088
1089 CALL mstart('Iteration') ! Solution module starting
1090
1091 CALL xloopn ! all methods
1092
1093 ! ------------------------------------------------------------------
1094
1095 IF(nloopn > 2.AND.nhistp /= 0) THEN ! last iteration
1096 CALL hmprnt(3) ! scaled residual of single measurement (with global deriv.)
1097 CALL hmprnt(12) ! scaled residual of single measurement (no global deriv.)
1098 CALL hmprnt(4) ! chi^2/Ndf
1099 END IF
1100 IF(nloopn > 2) THEN
1101 CALL hmpwrt(3)
1102 CALL hmpwrt(12)
1103 CALL hmpwrt(4)
1104 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
1105 IF (nloopn <= lfitnp) THEN
1106 CALL hmpwrt(13)
1107 CALL hmpwrt(14)
1108 CALL gmpwrt(5)
1109 END IF
1110 END IF
1111 IF(nhistp /= 0) THEN
1112 CALL gmprnt(1)
1113 CALL gmprnt(2)
1114 END IF
1115 CALL gmpwrt(1) ! output of xy data
1116 CALL gmpwrt(2) ! output of xy data
1117 ! 'track quality' per binary file
1118 IF (nfilb > 1) THEN
1119 CALL gmpdef(6,1,'log10(#records) vs file number')
1120 CALL gmpdef(7,1,'final rejection fraction vs file number')
1121 CALL gmpdef(8,1, &
1122 'final <Chi^2/Ndf> from accepted local fits vs file number')
1123 CALL gmpdef(9,1, '<Ndf> from accepted local fits vs file number')
1124
1125 DO i=1,nfilb
1126 kfl=kfd(2,i)
1127 nrc=-kfd(1,i)
1128 IF (nrc > 0) THEN
1129 rej=real(nrc-jfd(kfl),mps)/real(nrc,mps)
1130 CALL gmpxy(6,real(kfl,mps),log10(real(nrc,mps))) ! log10(#records) vs file
1131 CALL gmpxy(7,real(kfl,mps),rej) ! rejection fraction vs file
1132 END IF
1133 IF (jfd(kfl) > 0) THEN
1134 c2ndf=cfd(kfl)/real(jfd(kfl),mps)
1135 CALL gmpxy(8,real(kfl,mps),c2ndf) ! <Chi2/NDF> vs file
1136 andf=real(dfd(kfl),mps)/real(jfd(kfl),mps)
1137 CALL gmpxy(9,real(kfl,mps),andf) ! <NDF> vs file
1138 END IF
1139 END DO
1140 IF(nhistp /= 0) THEN
1141 CALL gmprnt(6)
1142 CALL gmprnt(7)
1143 CALL gmprnt(8)
1144 CALL gmprnt(9)
1145 END IF
1146 CALL gmpwrt(6) ! output of xy data
1147 CALL gmpwrt(7) ! output of xy data
1148 CALL gmpwrt(8) ! output of xy data
1149 CALL gmpwrt(9) ! output of xy data
1150 END IF
1151
1152 IF(ictest == 1) THEN
1153 WRITE(*,*) ' '
1154 WRITE(*,*) 'Misalignment test wire chamber'
1155 WRITE(*,*) ' '
1156
1157 CALL hmpdef( 9,-0.0015,+0.0015,'True - fitted displacement')
1158 CALL hmpdef(10,-0.0015,+0.0015,'True - fitted Vdrift')
1159 DO i=1,4
1160 sums(i)=0.0_mpd
1161 END DO
1162 DO i=1,nplan
1163 diff=real(-del(i)-globalparameter(i),mps)
1164 sums(1)=sums(1)+diff
1165 sums(2)=sums(2)+diff*diff
1166 diff=real(-dvd(i)-globalparameter(100+i),mps)
1167 sums(3)=sums(3)+diff
1168 sums(4)=sums(4)+diff*diff
1169 END DO
1170 sums(1)=0.01_mpd*sums(1)
1171 sums(2)=sqrt(0.01_mpd*sums(2))
1172 sums(3)=0.01_mpd*sums(3)
1173 sums(4)=sqrt(0.01_mpd*sums(4))
1174 WRITE(*,143) 'Parameters 1 - 100: mean =',sums(1), 'rms =',sums(2)
1175 WRITE(*,143) 'Parameters 101 - 200: mean =',sums(3), 'rms =',sums(4)
1176143 FORMAT(6x,a28,f9.6,3x,a5,f9.6)
1177 WRITE(*,*) ' '
1178 WRITE(*,*) ' '
1179 WRITE(*,*) ' I label simulated fitted diff'
1180 WRITE(*,*) ' -------------------------------------------- '
1181 DO i=1,100
1182 WRITE(*,102) i,globalparlabelindex(1,i),-del(i),globalparameter(i),-del(i)-globalparameter(i)
1183 diff=real(-del(i)-globalparameter(i),mps)
1184 CALL hmpent( 9,diff)
1185 END DO
1186 DO i=101,200
1187 WRITE(*,102) i,globalparlabelindex(1,i),-dvd(i-100),globalparameter(i),-dvd(i-100)-globalparameter(i)
1188 diff=real(-dvd(i-100)-globalparameter(i),mps)
1189 CALL hmpent(10,diff)
1190 END DO
1191 IF(nhistp /= 0) THEN
1192 CALL hmprnt( 9)
1193 CALL hmprnt(10)
1194 END IF
1195 CALL hmpwrt( 9)
1196 CALL hmpwrt(10)
1197 END IF
1198 IF(ictest > 1) THEN
1199 WRITE(*,*) ' '
1200 WRITE(*,*) 'Misalignment test Si tracker'
1201 WRITE(*,*) ' '
1202
1203 CALL hmpdef( 9,-0.0025,+0.0025,'True - fitted displacement X')
1204 CALL hmpdef(10,-0.025,+0.025,'True - fitted displacement Y')
1205 DO i=1,9
1206 sums(i)=0.0_mpd
1207 END DO
1208 nmxy=nmx*nmy
1209 ix=0
1210 iy=ntot
1211 DO i=1,nlyr
1212 DO k=1,nmxy
1213 ix=ix+1
1214 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1215 sums(1)=sums(1)+1.0_mpd
1216 sums(2)=sums(2)+diff
1217 sums(3)=sums(3)+diff*diff
1218 ixv=globalparlabelindex(2,ix)
1219 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1220 ii=(ixv*ixv+ixv)/2
1221 gmati=real(globalmatd(ii),mps)
1222 err=sqrt(abs(gmati))
1223 diff=diff/err
1224 sums(7)=sums(7)+1.0_mpd
1225 sums(8)=sums(8)+diff
1226 sums(9)=sums(9)+diff*diff
1227 END IF
1228 END DO
1229 IF (mod(i,3) == 1) THEN
1230 DO k=1,nmxy
1231 iy=iy+1
1232 diff=-real(sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1233 sums(4)=sums(4)+1.0_mpd
1234 sums(5)=sums(5)+diff
1235 sums(6)=sums(6)+diff*diff
1236 ixv=globalparlabelindex(2,iy)
1237 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1238 ii=(ixv*ixv+ixv)/2
1239 gmati=real(globalmatd(ii),mps)
1240 err=sqrt(abs(gmati))
1241 diff=diff/err
1242 sums(7)=sums(7)+1.0_mpd
1243 sums(8)=sums(8)+diff
1244 sums(9)=sums(9)+diff*diff
1245 END IF
1246 END DO
1247 END IF
1248 END DO
1249 sums(2)=sums(2)/sums(1)
1250 sums(3)=sqrt(sums(3)/sums(1))
1251 sums(5)=sums(5)/sums(4)
1252 sums(6)=sqrt(sums(6)/sums(4))
1253 WRITE(*,143) 'Parameters 1 - 500: mean =',sums(2), 'rms =',sums(3)
1254 WRITE(*,143) 'Parameters 501 - 700: mean =',sums(5), 'rms =',sums(6)
1255 IF (sums(7) > 0.5_mpd) THEN
1256 sums(8)=sums(8)/sums(7)
1257 sums(9)=sqrt(sums(9)/sums(7))
1258 WRITE(*,143) 'Parameter pulls, all: mean =',sums(8), 'rms =',sums(9)
1259 END IF
1260 WRITE(*,*) ' '
1261 WRITE(*,*) ' '
1262 WRITE(*,*) ' I label simulated fitted diff'
1263 WRITE(*,*) ' -------------------------------------------- '
1264 ix=0
1265 iy=ntot
1266 DO i=1,nlyr
1267 DO k=1,nmxy
1268 ix=ix+1
1269 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1270 CALL hmpent( 9,diff)
1271 WRITE(*,102) ix,globalparlabelindex(1,ix),-sdevx((i-1)*nmxy+k),globalparameter(ix),-diff
1272 END DO
1273 END DO
1274 DO i=1,nlyr
1275 IF (mod(i,3) == 1) THEN
1276 DO k=1,nmxy
1277 iy=iy+1
1278 diff=real(-sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1279 CALL hmpent(10,diff)
1280 WRITE(*,102) iy,globalparlabelindex(1,iy),-sdevy((i-1)*nmxy+k),globalparameter(iy),-diff
1281 END DO
1282 END IF
1283 END DO
1284 IF(nhistp /= 0) THEN
1285 CALL hmprnt( 9)
1286 CALL hmprnt(10)
1287 END IF
1288 CALL hmpwrt( 9)
1289 CALL hmpwrt(10)
1290 END IF
1291
1292 IF(nrec1+nrec2 > 0) THEN
1293 WRITE(8,*) ' '
1294 IF(nrec1 > 0) THEN
1295 WRITE(8,*) 'Record',nrec1,' has largest residual:',value1
1296 END IF
1297 IF(nrec2 > 0) THEN
1298 WRITE(8,*) 'Record',nrec2,' has largest Chi^2/Ndf:',value2
1299 END IF
1300 END IF
1301 IF(nrec3 < huge(nrec3)) THEN
1302 WRITE(8,*) 'Record',nrec3, ' is first with error (rank deficit/NaN)'
1303 END IF
130499 WRITE(8,*) ' '
1305 IF (iteren > mreqenf) THEN
1306 WRITE(8,*) 'In total 3 +',nloopn,' loops through the data files'
1307 ELSE
1308 WRITE(8,*) 'In total 2 +',nloopn,' loops through the data files'
1309 ENDIF
1310 IF (mnrsit > 0) THEN
1311 WRITE(8,*) ' '
1312 WRITE(8,*) 'In total ',mnrsit,' internal MINRES iterations'
1313 END IF
1314
1315 WRITE(8,103) times(0),times(1),times(2),times(4),times(7), &
1316 times(5),times(8),times(3),times(6)
1317
1318 rst=etime(ta)
1319 deltat=rst-rstp
1320 ntsec=nint(deltat,mpi)
1321 CALL sechms(deltat,nhour,minut,secnd)
1322 nsecnd=nint(secnd,mpi) ! round
1323 WRITE(8,*) 'Total time =',ntsec,' seconds =',nhour,' h',minut, &
1324 ' m',nsecnd,' seconds'
1325 CALL fdate(chdate)
1326 WRITE(8,*) 'end ', chdate
1327 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1328 WRITE(8,*) ' '
1329 WRITE(8,105) gbu
1330
1331 ! Rejects ----------------------------------------------------------
1332
1333 IF(nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) /= 0) THEN
1334 WRITE(8,*) ' '
1335 WRITE(8,*) 'Data rejected in last iteration: '
1336 WRITE(8,*) ' ', &
1337 nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', &
1338 nrejec(2), ' (huge) ',nrejec(3),' (large)'
1339 WRITE(8,*) ' '
1340 END IF
1341 IF (icheck <= 0) CALL explfc(8)
1342
1343 WRITE(*,*) ' '
1344 WRITE(*,*) ' < Millepede II-P ending ... ', chdate ! with exit code',ITEXIT,' >'
1345 WRITE(*,*) ' '
1346 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1347 WRITE(*,105) gbu
1348#ifdef LAPACK64
1349#ifdef PARDISO
1350 IF(ipdmem > 0) WRITE(*,106) real(ipdmem,mps)*1.e-6
1351106 FORMAT(' PARDISO dyn. memory allocation: ',f11.6,' GB')
1352#endif
1353#endif
1354 WRITE(*,*) ' '
1355
1356102 FORMAT(2x,i4,i10,2x,3f10.5)
1357103 FORMAT(' Times [in sec] for text processing',f12.3/ &
1358 ' LOOP1',f12.3/ &
1359 ' LOOP2',f12.3/ &
1360 ' func. value ',f12.3,' *',f4.0/ &
1361 ' func. value, global matrix, solution',f12.3,' *',f4.0/ &
1362 ' new solution',f12.3,' *',f4.0/)
1363105 FORMAT(' Peak dynamic memory allocation: ',f11.6,' GB')
1364END PROGRAM mptwo ! Mille
1365
1372
1373SUBROUTINE solglo(ivgbi)
1374 USE mpmod
1375 USE minresmodule, ONLY: minres
1376
1377 IMPLICIT NONE
1378 REAL(mps) :: par
1379 REAL(mps) :: dpa
1380 REAL(mps) :: err
1381 REAL(mps) :: gcor2
1382 INTEGER(mpi) :: iph
1383 INTEGER(mpi) :: istop
1384 INTEGER(mpi) :: itgbi
1385 INTEGER(mpi) :: itgbl
1386 INTEGER(mpi) :: itn
1387 INTEGER(mpi) :: itnlim
1388 INTEGER(mpi) :: nout
1389
1390 INTEGER(mpi), INTENT(IN) :: ivgbi
1391
1392 REAL(mpd) :: shift
1393 REAL(mpd) :: rtol
1394 REAL(mpd) :: anorm
1395 REAL(mpd) :: acond
1396 REAL(mpd) :: arnorm
1397 REAL(mpd) :: rnorm
1398 REAL(mpd) :: ynorm
1399 REAL(mpd) :: gmati
1400 REAL(mpd) :: diag
1401 REAL(mpd) :: matij
1402 LOGICAL :: checka
1403 EXTERNAL avprod, mcsolv, mvsolv
1404 SAVE
1405 DATA iph/0/
1406 ! ...
1407 IF(iph == 0) THEN
1408 iph=1
1409 WRITE(*,101)
1410 END IF
1411 itgbi=globalparvartototal(ivgbi)
1412 itgbl=globalparlabelindex(1,itgbi)
1413
1414 globalvector=0.0_mpd ! reset rhs vector IGVEC
1415 globalvector(ivgbi)=1.0_mpd
1416
1417 ! NOUT =6
1418 nout =0
1419 itnlim=200
1420 shift =0.0_mpd
1421 rtol = mrestl ! from steering
1422 checka=.false.
1423
1424
1425 IF(mbandw == 0) THEN ! default preconditioner
1426 CALL minres(nagb, avprod, mcsolv, globalvector, shift, checka ,.true. , &
1427 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1428
1429 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1430 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.true. , &
1431 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1432 ELSE
1433 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.false. , &
1434 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1435 END IF
1436
1437 par=real(globalparameter(itgbi),mps)
1438 dpa=real(par-globalparstart(itgbi),mps)
1439 gmati=globalcorrections(ivgbi)
1440 err=sqrt(abs(real(gmati,mps)))
1441 IF(gmati < 0.0_mpd) err=-err
1442 diag=matij(ivgbi,ivgbi)
1443 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1444 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1445101 FORMAT(1x,' label parameter presigma differ', &
1446 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1447102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1448END SUBROUTINE solglo
1449
1456
1457SUBROUTINE solgloqlp(ivgbi)
1458 USE mpmod
1459 USE minresqlpmodule, ONLY: minresqlp
1460
1461 IMPLICIT NONE
1462 REAL(mps) :: par
1463 REAL(mps) :: dpa
1464 REAL(mps) :: err
1465 REAL(mps) :: gcor2
1466 INTEGER(mpi) :: iph
1467 INTEGER(mpi) :: istop
1468 INTEGER(mpi) :: itgbi
1469 INTEGER(mpi) :: itgbl
1470 INTEGER(mpi) :: itn
1471 INTEGER(mpi) :: itnlim
1472 INTEGER(mpi) :: nout
1473
1474 INTEGER(mpi), INTENT(IN) :: ivgbi
1475
1476 REAL(mpd) :: shift
1477 REAL(mpd) :: rtol
1478 REAL(mpd) :: mxxnrm
1479 REAL(mpd) :: trcond
1480 REAL(mpd) :: gmati
1481 REAL(mpd) :: diag
1482 REAL(mpd) :: matij
1483
1484 EXTERNAL avprod, mcsolv, mvsolv
1485 SAVE
1486 DATA iph/0/
1487 ! ...
1488 IF(iph == 0) THEN
1489 iph=1
1490 WRITE(*,101)
1491 END IF
1492 itgbi=globalparvartototal(ivgbi)
1493 itgbl=globalparlabelindex(1,itgbi)
1494
1495 globalvector=0.0_mpd ! reset rhs vector IGVEC
1496 globalvector(ivgbi)=1.0_mpd
1497
1498 ! NOUT =6
1499 nout =0
1500 itnlim=200
1501 shift =0.0_mpd
1502 rtol = mrestl ! from steering
1503 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
1504 IF(mrmode == 1) THEN
1505 trcond = 1.0_mpd/epsilon(trcond) ! only QR
1506 ELSE IF(mrmode == 2) THEN
1507 trcond = 1.0_mpd ! only QLP
1508 ELSE
1509 trcond = mrtcnd ! QR followed by QLP
1510 END IF
1511
1512 IF(mbandw == 0) THEN ! default preconditioner
1513 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mcsolv, nout=nout, &
1514 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1515 x=globalcorrections, istop=istop, itn=itn)
1516 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1517 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mvsolv, nout=nout, &
1518 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1519 x=globalcorrections, istop=istop, itn=itn)
1520 ELSE
1521 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, nout=nout, &
1522 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1523 x=globalcorrections, istop=istop, itn=itn)
1524 END IF
1525
1526 par=real(globalparameter(itgbi),mps)
1527 dpa=real(par-globalparstart(itgbi),mps)
1528 gmati=globalcorrections(ivgbi)
1529 err=sqrt(abs(real(gmati,mps)))
1530 IF(gmati < 0.0_mpd) err=-err
1531 diag=matij(ivgbi,ivgbi)
1532 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1533 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1534101 FORMAT(1x,' label parameter presigma differ', &
1535 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1536102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1537END SUBROUTINE solgloqlp
1538
1540SUBROUTINE addcst
1541 USE mpmod
1542
1543 IMPLICIT NONE
1544 REAL(mpd) :: climit
1545 REAL(mpd) :: factr
1546 REAL(mpd) :: sgm
1547
1548 INTEGER(mpi) :: i
1549 INTEGER(mpi) :: icgb
1550 INTEGER(mpi) :: irhs
1551 INTEGER(mpi) :: itgbi
1552 INTEGER(mpi) :: ivgb
1553 INTEGER(mpi) :: j
1554 INTEGER(mpi) :: jcgb
1555 INTEGER(mpi) :: l
1556 INTEGER(mpi) :: label
1557 INTEGER(mpi) :: nop
1558 INTEGER(mpi) :: inone
1559
1560 REAL(mpd) :: rhs
1561 REAL(mpd) :: drhs(4)
1562 INTEGER(mpi) :: idrh (4)
1563 SAVE
1564 ! ...
1565 nop=0
1566 IF(lenconstraints == 0) RETURN ! no constraints
1567 climit=1.0e-5 ! limit for printout
1568 irhs=0 ! number of values in DRHS(.), to be printed
1569
1570 DO jcgb=1,ncgb
1571 icgb=matconssort(3,jcgb) ! unsorted constraint index
1572 i=vecconsstart(icgb)
1573 rhs=listconstraints(i )%value ! right hand side
1574 sgm=listconstraints(i+1)%value ! sigma parameter
1575 DO j=i+2,vecconsstart(icgb+1)-1
1576 label=listconstraints(j)%label
1577 factr=listconstraints(j)%value
1578 itgbi=inone(label) ! -> ITGBI= index of parameter label
1579 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
1580
1581 IF(icalcm == 1.AND.nagb > nvgb.AND.ivgb > 0) THEN
1582 CALL mupdat(nvgb+jcgb,ivgb,factr) ! add to matrix
1583 END IF
1584
1585 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
1586 END DO
1587 IF(abs(rhs) > climit) THEN
1588 irhs=irhs+1
1589 idrh(irhs)=jcgb
1590 drhs(irhs)=rhs
1591 nop=1
1592 IF(irhs == 4) THEN
1593 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1594 irhs=0
1595 END IF
1596 END IF
1597 vecconsresiduals(jcgb)=rhs
1598 IF (nagb > nvgb) globalvector(nvgb+jcgb)=rhs
1599 END DO
1600
1601 IF(irhs /= 0) THEN
1602 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1603 END IF
1604 IF(nop == 0) RETURN
1605 WRITE(*,102) ' Constraints: only equation values >', climit,' are printed'
1606101 FORMAT(' ',4(i6,g11.3))
1607102 FORMAT(a,g11.2,a)
1608END SUBROUTINE addcst
1609
1614SUBROUTINE grpcon
1615 USE mpmod
1616 USE mpdalc
1617
1618 IMPLICIT NONE
1619 INTEGER(mpi) :: i
1620 INTEGER(mpi) :: icgb
1621 INTEGER(mpi) :: icgrp
1622 INTEGER(mpi) :: ioff
1623 INTEGER(mpi) :: itgbi
1624 INTEGER(mpi) :: j
1625 INTEGER(mpi) :: jcgb
1626 INTEGER(mpi) :: label
1627 INTEGER(mpi) :: labelf
1628 INTEGER(mpi) :: labell
1629 INTEGER(mpi) :: last
1630 INTEGER(mpi) :: line1
1631 INTEGER(mpi) :: ncon
1632 INTEGER(mpi) :: ndiff
1633 INTEGER(mpi) :: npar
1634 INTEGER(mpi) :: inone
1635 INTEGER(mpi) :: itype
1636 INTEGER(mpi) :: ncgbd
1637 INTEGER(mpi) :: ncgbr
1638 INTEGER(mpi) :: ncgbw
1639 INTEGER(mpi) :: ncgrpd
1640 INTEGER(mpi) :: ncgrpr
1641 INTEGER(mpi) :: next
1642
1643 INTEGER(mpl):: length
1644 INTEGER(mpl) :: rows
1645
1646 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsOffsets
1647 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsList
1648 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParOffsets
1649 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParList
1650 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1651
1652 ncgb=0
1653 ncgbw=0
1654 IF(lenconstraints == 0) RETURN ! no constraints
1655
1656 i=0
1657 last=0
1658 itype=0
1659 ! find next constraint header and count nr of constraints
1660 DO WHILE(i < lenconstraints)
1661 i=i+1
1662 label=listconstraints(i)%label
1663 IF(last < 0.AND.label < 0) THEN
1664 ncgb=ncgb+1
1665 itype=-label
1666 IF(itype == 2) ncgbw=ncgbw+1
1667 END IF
1668 last=label
1669 IF(label > 0) THEN
1670 itgbi=inone(label) ! -> ITGBI= index of parameter label
1671 globalparcons(itgbi)=globalparcons(itgbi)+1
1672 END IF
1673 IF(label > 0.AND.itype == 2) THEN ! weighted constraints
1674 itgbi=inone(label) ! -> ITGBI= index of parameter label
1675 listconstraints(i)%value=listconstraints(i)%value*globalparlabelcounter(itgbi)
1676 END IF
1677 END DO
1678
1679 WRITE(*,*)
1680 IF (ncgbw == 0) THEN
1681 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files'
1682 ELSE
1683 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files,',ncgbw, 'weighted'
1684 END IF
1685 WRITE(*,*)
1686
1687 ! keys and index for sorting of constraints
1688 length=ncgb+1; rows=3
1689 CALL mpalloc(matconssort,rows,length,'keys and index for sorting (I)')
1690 matconssort(1,ncgb+1)=ntgb+1
1691 ! start of constraint in list
1692 CALL mpalloc(vecconsstart,length,'start of constraint in list (I)')
1693 vecconsstart(ncgb+1)=lenconstraints+1
1694 ! start and parameter range of constraint groups
1695 CALL mpalloc(matconsgroups,rows,length,'start of constraint groups, par. range (I)')
1696 ! parameter ranges (all, variable) of constraints
1697 length=ncgb; rows=4
1698 CALL mpalloc(matconsranges,rows,length,'parameter ranges for constraint (I)')
1699
1700 length=ncgb; rows=3
1701 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
1702 matconsgroupindex=0
1703 length=ncgb+1
1704 CALL mpalloc(vecconsparoffsets,length,'offsets for global par list for cons. (I)')
1705 length=ntgb+1
1706 CALL mpalloc(vecparconsoffsets,length,'offsets for cons. list for global par. (I)')
1707 vecparconsoffsets(1)=0
1708 DO i=1,ntgb
1709 vecparconsoffsets(i+1)=vecparconsoffsets(i)+globalparcons(i)
1710 END DO
1711 globalparcons=0
1712
1713 length=vecparconsoffsets(ntgb+1)
1714 CALL mpalloc(vecconsparlist,length,'global par. list for constraint (I)')
1715 CALL mpalloc(vecparconslist,length,'constraint list for global par. (I)')
1716
1717 ! prepare
1718 i=1
1719 ioff=0
1720 vecconsparoffsets(1)=ioff
1721 DO icgb=1,ncgb
1722 ! new constraint
1723 vecconsstart(icgb)=i
1724 line1=-listconstraints(i)%label
1725 npar=0
1726 i=i+2
1727 DO
1728 label=listconstraints(i)%label
1729 itgbi=inone(label) ! -> ITGBI= index of parameter label
1730 ! list of constraints for 'itgbi'
1731 globalparcons(itgbi)=globalparcons(itgbi)+1
1732 vecparconslist(vecparconsoffsets(itgbi)+globalparcons(itgbi))=icgb
1733 npar=npar+1
1734 vecconsparlist(ioff+npar)=itgbi
1735 i=i+1
1736 IF(i > lenconstraints) EXIT
1737 IF(listconstraints(i)%label < 0) EXIT
1738 END DO
1739 ! sort to find duplicates
1740 CALL sort1k(vecconsparlist(ioff+1),npar)
1741 last=-1
1742 ndiff=0
1743 DO j=1,npar
1744 next=vecconsparlist(ioff+j)
1745 IF (next /= last) THEN
1746 ndiff=ndiff+1
1747 vecconsparlist(ioff+ndiff) = next
1748 END IF
1749 last=next
1750 END DO
1751 matconsranges(1,icgb)=vecconsparlist(ioff+1) ! min parameter
1752 matconsranges(3,icgb)=vecconsparlist(ioff+1) ! min parameter
1753 ioff=ioff+ndiff
1754 matconsranges(2,icgb)=vecconsparlist(ioff) ! max parameter
1755 matconsranges(4,icgb)=vecconsparlist(ioff) ! max parameter
1756 vecconsparoffsets(icgb+1)=ioff
1757 END DO
1758 vecconsstart(ncgb+1)=lenconstraints+1
1759
1760 ! sort (by first, last parameter)
1761 DO icgb=1,ncgb
1762 matconssort(1,icgb)=matconsranges(1,icgb) ! first par.
1763 matconssort(2,icgb)=matconsranges(2,icgb) ! last par.
1764 matconssort(3,icgb)=icgb ! index
1765 END DO
1766 CALL sort2i(matconssort,ncgb)
1767
1768 IF (icheck>1) THEN
1769 print *, ' Constraint #parameters first par. last par. first line'
1770 END IF
1771 ! split into disjoint groups
1772 ncgrp=0
1773 globalparcons=0
1774 DO jcgb=1,ncgb
1775 icgb=matconssort(3,jcgb)
1776 IF (icheck>0) THEN
1777 npar=vecconsparoffsets(icgb+1)-vecconsparoffsets(icgb)
1778 line1=-listconstraints(vecconsstart(icgb))%label
1779 labelf=globalparlabelindex(1,matconsranges(1,icgb))
1780 labell=globalparlabelindex(1,matconsranges(2,icgb))
1781 print *, jcgb, npar, labelf, labell, line1
1782 END IF
1783 ! already part of group?
1784 icgrp=matconsgroupindex(1,icgb)
1785 IF (icgrp == 0) THEN
1786 ! check all parameters
1787 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1788 itgbi=vecconsparlist(i)
1789 ! check all related constraints
1790 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1791 icgrp=matconsgroupindex(1,vecparconslist(j))
1792 ! already part of group?
1793 IF (icgrp > 0) EXIT
1794 END DO
1795 IF (icgrp > 0) EXIT
1796 END DO
1797 IF (icgrp == 0) THEN
1798 ! new group
1799 ncgrp=ncgrp+1
1800 icgrp=ncgrp
1801 END IF
1802 END IF
1803 ! add to group
1804 matconsgroupindex(2,icgb)=jcgb
1805 matconsgroupindex(3,icgb)=icgb
1806 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1807 itgbi=vecconsparlist(i)
1808 globalparcons(itgbi)=icgrp
1809 ! mark all related constraints
1810 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1811 matconsgroupindex(1,vecparconslist(j))=icgrp
1812 END DO
1813 END DO
1814 END DO
1815 WRITE(*,*) 'GRPCON:',ncgrp,' disjoint constraints groups built'
1816
1817 ! sort by group number
1818 CALL sort2i(matconsgroupindex,ncgb)
1819
1820 matconsgroups(1,1:ncgrp)=0
1821 DO jcgb=1,ncgb
1822 ! set up matConsSort
1823 icgb=matconsgroupindex(3,jcgb)
1824 matconssort(1,jcgb)=matconsranges(1,icgb)
1825 matconssort(2,jcgb)=matconsranges(2,icgb)
1826 matconssort(3,jcgb)=icgb
1827 ! set up matConsGroups
1828 icgrp=matconsgroupindex(1,jcgb)
1829 IF (matconsgroups(1,icgrp) == 0) THEN
1830 matconsgroups(1,icgrp)=jcgb
1831 matconsgroups(2,icgrp)=matconsranges(1,icgb)
1832 matconsgroups(3,icgrp)=matconsranges(2,icgb)
1833 ELSE
1834 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
1835 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
1836 END IF
1837 END DO
1838 matconsgroups(1,ncgrp+1)=ncgb+1
1839 matconsgroups(2,ncgrp+1)=ntgb+1
1840
1841 ! check for redundancy constraint groups
1842 ncgbr=0
1843 ncgrpr=0
1844 ncgbd=0
1845 ncgrpd=0
1846 IF (icheck>0) THEN
1847 print *
1848 print *, ' cons.group first con. first par. last par. #cons #par'
1849 ENDIF
1850 DO icgrp=1,ncgrp
1851 npar=0
1852 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1853 IF (globalparcons(i) == icgrp) npar=npar+1
1854 END DO
1855 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
1856 IF (icheck>0) THEN
1857 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1858 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1859 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ncon, npar
1860 END IF
1861 ! redundancy constraints?
1862 IF (ncon == npar) THEN
1863 IF (irslvrc > 0) THEN
1864 ncgrpr=ncgrpr+1
1865 ncgbr=ncgbr+ncon
1866 IF (icheck > 0) THEN
1867 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1868 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1869 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group resolved'
1870 END IF
1871 ! flag redundant parameters
1872 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1873 IF (globalparcons(i) == icgrp) globalparcons(i)=-icgrp
1874 END DO
1875 ! flag constraint group
1876 matconsgroups(2,icgrp)=ntgb+1
1877 matconsgroups(3,icgrp)=ntgb
1878 ELSE
1879 ncgrpd=ncgrpd+1
1880 ncgbd=ncgbd+ncon
1881 IF (icheck > 0) THEN
1882 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1883 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1884 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group redundant'
1885 END IF
1886 END IF
1887 END IF
1888 END DO
1889 IF (ncgrpr > 0) THEN
1890 WRITE(*,*) 'GRPCON:',ncgbr,' redundancy constraints in ', ncgrpr, ' groups resolved'
1891 ! all constraint groups resolved ?
1892 IF (ncgrpr == ncgrp) ncgrp=0
1893 ENDIF
1894 IF (ncgrpd > 0) THEN
1895 WRITE(*,*) 'GRPCON:',ncgbd,' redundancy constraints in ', ncgrpd, ' groups detected'
1896 ENDIF
1897 WRITE(*,*)
1898
1899 ! clean up
1900 CALL mpdealloc(vecparconslist)
1901 CALL mpdealloc(vecconsparlist)
1902 CALL mpdealloc(vecparconsoffsets)
1903 CALL mpdealloc(vecconsparoffsets)
1904 CALL mpdealloc(matconsgroupindex)
1905
1906END SUBROUTINE grpcon
1907
1911
1912SUBROUTINE prpcon
1913 USE mpmod
1914 USE mpdalc
1915
1916 IMPLICIT NONE
1917 INTEGER(mpi) :: i
1918 INTEGER(mpi) :: icgb
1919 INTEGER(mpi) :: icgrp
1920 INTEGER(mpi) :: ifrst
1921 INTEGER(mpi) :: ilast
1922 INTEGER(mpi) :: isblck
1923 INTEGER(mpi) :: itgbi
1924 INTEGER(mpi) :: ivgb
1925 INTEGER(mpi) :: j
1926 INTEGER(mpi) :: jcgb
1927 INTEGER(mpi) :: jfrst
1928 INTEGER(mpi) :: label
1929 INTEGER(mpi) :: labelf
1930 INTEGER(mpi) :: labell
1931 INTEGER(mpi) :: ncon
1932 INTEGER(mpi) :: ngrp
1933 INTEGER(mpi) :: npar
1934 INTEGER(mpi) :: ncnmxb
1935 INTEGER(mpi) :: ncnmxg
1936 INTEGER(mpi) :: nprmxb
1937 INTEGER(mpi) :: nprmxg
1938 INTEGER(mpi) :: inone
1939 INTEGER(mpi) :: nvar
1940
1941 INTEGER(mpl):: length
1942 INTEGER(mpl) :: rows
1943
1944 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1945
1946 ncgbe=0
1947 !
1948 ! constraint groups already built in GRPCON based on steering,
1949 ! now care about fixed parameters
1950 !
1951 IF(ncgrp == 0) THEN ! no constraints groups
1952 ncgb=0
1953 ncblck=0
1954 RETURN
1955 END IF
1956
1957 length=ncgrp+1; rows=3
1958 ! start and parameter range of constraint blocks
1959 CALL mpalloc(matconsblocks,rows,length,'start of constraint blocks, par. range (I)')
1960
1961 length=ncgb; rows=3
1962 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
1963 matconsgroupindex=0
1964
1965 ! check for empty constraints, redefine (accepted/active) constraints and groups
1966 ngrp=0
1967 ncgb=0
1968 DO icgrp=1,ncgrp
1969 ncon=ncgb
1970 ! resolved group ?
1971 IF (matconsgroups(2,icgrp) > matconsgroups(3,icgrp)) cycle
1972 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
1973 icgb=matconssort(3,jcgb)
1974 i=vecconsstart(icgb)+2
1975 npar=0
1976 nvar=0
1977 matconsranges(1,icgb)=ntgb
1978 matconsranges(2,icgb)=1
1979 DO
1980 label=listconstraints(i)%label
1981 itgbi=inone(label) ! -> ITGBI= index of parameter label
1982 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
1983 npar=npar+1
1984 IF(ivgb > 0) THEN
1985 nvar=nvar+1
1986 matconsranges(1,icgb)=min(matconsranges(1,icgb),itgbi)
1987 matconsranges(2,icgb)=max(matconsranges(2,icgb),itgbi)
1988 ENDIF
1989 i=i+1
1990 IF(i > lenconstraints) EXIT
1991 IF(listconstraints(i)%label < 0) EXIT
1992 END DO
1993 IF (nvar == 0) THEN
1994 ncgbe=ncgbe+1
1995 ! reset range
1996 matconsranges(1,icgb)=matconsranges(3,icgb)
1997 matconsranges(2,icgb)=matconsranges(4,icgb)
1998 END IF
1999 IF (nvar > 0 .OR. iskpec == 0) THEN
2000 ! constraint accepted (or kept)
2001 ncgb=ncgb+1
2002 matconsgroupindex(1,ncgb)=ngrp+1
2003 matconsgroupindex(2,ncgb)=icgb
2004 matconsgroupindex(3,ncgb)=nvar
2005 END IF
2006 END DO
2007 IF (ncgb > ncon) ngrp=ngrp+1
2008 END DO
2009 ncgrp=ngrp
2010
2011 IF (ncgbe > 0) THEN
2012 IF (iskpec > 0) THEN
2013 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints skipped'
2014 ELSE
2015 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints detected, to be fixed !!!'
2016 WRITE(*,*) ' (use option "skipemptycons" to skip those)'
2017 IF (icheck == 0) THEN
2018 icheck=2 ! switch to '-C'
2019 ncgbe=-ncgbe ! indicate that
2020 WRITE(*,*)
2021 WRITE(*,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2022 WRITE(8,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2023 WRITE(*,*)
2024 END IF
2025 END IF
2026 END IF
2027 WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted'
2028 WRITE(*,*)
2029
2030 IF(ncgb == 0) RETURN ! no constraints left
2031
2032 ! already sorted by group number
2033
2034 matconsgroups(1,1:ncgrp)=0
2035 DO jcgb=1,ncgb
2036 ! set up matConsSort
2037 icgb=matconsgroupindex(2,jcgb)
2038 matconssort(1,jcgb)=matconsranges(1,icgb)
2039 matconssort(2,jcgb)=matconsranges(2,icgb)
2040 matconssort(3,jcgb)=icgb
2041 ! set up matConsGroups
2042 icgrp=matconsgroupindex(1,jcgb)
2043 IF (matconsgroups(1,icgrp) == 0) THEN
2044 matconsgroups(1,icgrp)=jcgb
2045 matconsgroups(2,icgrp)=matconsranges(1,icgb)
2046 matconsgroups(3,icgrp)=matconsranges(2,icgb)
2047 ELSE
2048 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
2049 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
2050 END IF
2051 END DO
2052 matconsgroups(1,ncgrp+1)=ncgb+1
2053 matconsgroups(2,ncgrp+1)=ntgb+1
2054
2055 ! loop over constraints groups, combine into non overlapping blocks
2056 ncblck=0
2057 ncnmxg=0
2058 nprmxg=0
2059 ncnmxb=0
2060 nprmxb=0
2061 mszcon=0
2062 mszprd=0
2063 isblck=1
2064 ilast=0
2065 IF (icheck > 0) THEN
2066 WRITE(*,*)
2067 IF (icheck > 1) &
2068 WRITE(*,*) ' Cons. sorted index #var.par. first line first label last label'
2069 WRITE(*,*) ' Cons. group index first cons. last cons. first label last label'
2070 WRITE(*,*) ' Cons. block index first group last group first label last label'
2071 END IF
2072 DO icgrp=1,ncgrp
2073 IF (icheck > 1) THEN
2074 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2075 icgb=matconssort(3,jcgb)
2076 nvar=matconsgroupindex(3,jcgb)
2077 labelf=globalparlabelindex(1,matconssort(1,jcgb))
2078 labell=globalparlabelindex(1,matconssort(2,jcgb))
2079 IF (nvar > 0) THEN
2080 WRITE(*,*) ' Cons. sorted', jcgb, nvar, &
2081 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2082 ELSE
2083 WRITE(*,*) ' Cons. sorted', jcgb, ' empty (0)', &
2084 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2085 END IF
2086 END DO
2087 END IF
2088 IF (icheck > 0) THEN
2089 !ivgb=globalParLabelIndex(2,matConsGroups(2,icgrp)) ! -> index of variable global parameter
2090 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
2091 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
2092 WRITE(*,*) ' Cons. group ', icgrp, matconsgroups(1,icgrp), &
2093 matconsgroups(1,icgrp+1)-1, labelf, labell
2094 ENDIF
2095 ! combine into non overlapping blocks
2096 ilast=max(ilast, matconsgroups(3,icgrp))
2097 IF (matconsgroups(2,icgrp+1) > ilast) THEN
2098 ncblck=ncblck+1
2099 ifrst=matconsgroups(2,isblck)
2100 matconsblocks(1,ncblck)=matconsgroups(1,isblck)
2101 matconsblocks(2,ncblck)=ifrst ! save first parameter in block
2102 matconsblocks(3,ncblck)=ilast ! save last parameter in block
2103 ! update matConsSort
2104 jfrst=matconsgroups(2,icgrp)
2105 DO i=icgrp,isblck,-1
2106 DO j=matconsgroups(1,i),matconsgroups(1,i+1)-1
2107 ! non zero range (from group)
2108 matconsranges(1,j)=matconsgroups(2,i)
2109 matconsranges(2,j)=matconsgroups(3,i)
2110 ! storage range (from max group, ilast)
2111 jfrst=min(jfrst,matconsgroups(2,i))
2112 matconsranges(3,j)=jfrst
2113 matconsranges(4,j)=ilast
2114 END DO
2115 END DO
2116 IF (icheck > 0) THEN
2117 labelf=globalparlabelindex(1,ifrst)
2118 labell=globalparlabelindex(1,ilast)
2119 WRITE(*,*) ' Cons. block ', ncblck, isblck, icgrp, labelf, labell
2120 ENDIF
2121 ! reset for new block
2122 isblck=icgrp+1
2123 END IF
2124 END DO
2125 matconsblocks(1,ncblck+1)=ncgb+1
2126
2127 ! convert from total parameter index to index of variable global parameter
2128 DO i=1,ncblck
2129 ifrst=globalparlabelindex(2,matconsblocks(2,i)) ! -> index of variable global parameter
2130 ilast=globalparlabelindex(2,matconsblocks(3,i)) ! -> index of variable global parameter
2131 IF (ifrst > 0) THEN
2132 matconsblocks(2,i)=ifrst
2133 matconsblocks(3,i)=ilast
2134 ! statistics
2135 ncon=matconsblocks(1,i+1)-matconsblocks(1,i)
2136 npar=ilast+1-ifrst
2137 ncnmxb=max(ncnmxb,ncon)
2138 nprmxb=max(nprmxb,npar)
2139 ! update index ranges
2140 globalindexranges(ifrst)=max(globalindexranges(ifrst),ilast)
2141 ELSE
2142 ! empty
2143 matconsblocks(2,i)=1
2144 matconsblocks(3,i)=0
2145 END IF
2146 END DO
2147 DO icgrp=1,ncgrp
2148 ifrst=globalparlabelindex(2,matconsgroups(2,icgrp)) ! -> index of variable global parameter
2149 ilast=globalparlabelindex(2,matconsgroups(3,icgrp)) ! -> index of variable global parameter
2150 IF (ifrst > 0) THEN
2151 matconsgroups(2,icgrp)=ifrst
2152 matconsgroups(3,icgrp)=ilast
2153 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2154 DO i=1,4
2155 ivgb=globalparlabelindex(2,matconsranges(i,jcgb)) ! -> index of variable global parameter
2156 matconsranges(i,jcgb)=ivgb
2157 END DO
2158 END DO
2159 ! storage sizes, statistics
2160 jcgb=matconsgroups(1,icgrp) ! first cons.
2161 ncon=matconsgroups(1,icgrp+1)-jcgb
2162 npar=matconsranges(4,jcgb)+1-matconsranges(3,jcgb)
2163 ncnmxg=max(ncnmxg,ncon)
2164 nprmxg=max(nprmxg,npar)
2165 mszcon=mszcon+int(ncon,mpl)*int(npar,mpl) ! (sum of) block size for constraint matrix
2166 mszprd=mszprd+int(ncon,mpl)*int(ncon+1,mpl)/2 ! (sum of) block size for product matrix
2167 ELSE
2168 ! empty
2169 matconsgroups(2,icgrp)=1
2170 matconsgroups(3,icgrp)=0
2171 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2172 matconsranges(1,jcgb)=1
2173 matconsranges(2,jcgb)=0
2174 matconsranges(3,jcgb)=1
2175 matconsranges(4,jcgb)=0
2176 END DO
2177 END IF
2178 END DO
2179
2180 ! clean up
2181 CALL mpdealloc(matconsgroupindex)
2182
2183 ! save constraint group for global parameters
2184 globalparcons=0
2185 DO icgrp=1,ncgrp
2186 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2187 ! index in list
2188 icgb=matconssort(3,jcgb)
2189 DO j=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
2190 label=listconstraints(j)%label
2191 itgbi=inone(label) ! -> ITGBI= index of parameter label
2192 globalparcons(itgbi)=icgrp ! save constraint group
2193 END DO
2194 END DO
2195 END DO
2196
2197 IF (ncgrp+icheck > 1) THEN
2198 WRITE(*,*)
2199 WRITE(*,*) 'PRPCON: constraints split into ', ncgrp, '(disjoint) groups,'
2200 WRITE(*,*) ' groups combined into ', ncblck, '(non overlapping) blocks'
2201 WRITE(*,*) ' max group size (cons., par.) ', ncnmxg, nprmxg
2202 WRITE(*,*) ' max block size (cons., par.) ', ncnmxb, nprmxb
2203 IF (icheck > 0) WRITE(*,*) ' total block matrix sizes ', mszcon, mszprd
2204 END IF
2205
2206END SUBROUTINE prpcon
2207
2211
2212SUBROUTINE feasma
2213 USE mpmod
2214 USE mpdalc
2215
2216 IMPLICIT NONE
2217 REAL(mpd) :: factr
2218 REAL(mpd) :: sgm
2219 INTEGER(mpi) :: i
2220 INTEGER(mpi) :: icgb
2221 INTEGER(mpi) :: icgrp
2222 INTEGER(mpl) :: ij
2223 INTEGER(mpi) :: ifirst
2224 INTEGER(mpi) :: ilast
2225 INTEGER(mpl) :: ioffc
2226 INTEGER(mpl) :: ioffp
2227 INTEGER(mpi) :: irank
2228 INTEGER(mpi) :: ipar0
2229 INTEGER(mpi) :: itgbi
2230 INTEGER(mpi) :: ivgb
2231 INTEGER(mpi) :: j
2232 INTEGER(mpi) :: jcgb
2233 INTEGER(mpl) :: ll
2234 INTEGER(mpi) :: label
2235 INTEGER(mpi) :: ncon
2236 INTEGER(mpi) :: npar
2237 INTEGER(mpi) :: nrank
2238 INTEGER(mpi) :: inone
2239
2240 REAL(mpd):: rhs
2241 REAL(mpd):: evmax
2242 REAL(mpd):: evmin
2243 INTEGER(mpl):: length
2244 REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConstraintsT
2245 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
2246 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
2247 SAVE
2248 ! ...
2249
2250 IF(ncgb == 0) RETURN ! no constraints
2251
2252 ! product matrix A A^T (A is stored as transposed)
2253 length=mszprd
2254 CALL mpalloc(matconsproduct, length, 'product matrix of constraints (blocks)')
2255 matconsproduct=0.0_mpd
2256 length=ncgb
2257 CALL mpalloc(vecconsresiduals, length, 'residuals of constraints')
2258 CALL mpalloc(vecconssolution, length, 'solution for constraints')
2259 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
2260 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
2261 ! constraint matrix A (A is stored as transposed)
2262 length = mszcon
2263 CALL mpalloc(matconstraintst,length,'transposed matrix of constraints (blocks)')
2264 matconstraintst=0.0_mpd
2265
2266 ! loop over sorted constraints, fill matrices, get rank, inverted product matrix (in groups)
2267 ioffc=0 ! group offset in constraint matrix
2268 ioffp=0 ! group offset in product matrix
2269 nrank=0
2270 DO icgrp=1,ncgrp
2271 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2272 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2273 ncon=ilast+1-ifirst
2274 ipar0=matconsranges(3,ifirst)-1 ! parameter offset
2275 npar=matconsranges(4,ifirst)-ipar0 ! number of parameters
2276 IF (npar <= 0) THEN
2277 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, 0, ' (empty)'
2278 cycle ! skip empty groups/cons.
2279 END IF
2280 DO jcgb=ifirst,ilast
2281 ! index in list
2282 icgb=matconssort(3,jcgb)
2283 ! fill constraint matrix
2284 i=vecconsstart(icgb)
2285 rhs=listconstraints(i )%value ! right hand side
2286 sgm=listconstraints(i+1)%value ! sigma parameter
2287 DO j=i+2,vecconsstart(icgb+1)-1
2288 label=listconstraints(j)%label
2289 factr=listconstraints(j)%value
2290 itgbi=inone(label) ! -> ITGBI= index of parameter label
2291 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2292 IF(ivgb > 0) matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)= &
2293 matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)+factr ! matrix element
2294 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2295 END DO
2296 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2297 END DO
2298
2299 ! get rank of groups
2300 DO ll=ioffc+1,ioffc+npar
2301 ij=ioffp
2302 DO i=1,ncon
2303 DO j=1,i
2304 ij=ij+1
2305 matconsproduct(ij)=matconsproduct(ij)+ &
2306 matconstraintst(int(i-1,mpl)*int(npar,mpl)+ll)* &
2307 matconstraintst(int(j-1,mpl)*int(npar,mpl)+ll)
2308 END DO
2309 END DO
2310 END DO
2311 ! inversion of product matrix of constraints
2312 CALL sqminv(matconsproduct(ioffp+1:ij),vecconsresiduals(ifirst:ilast),ncon,irank, auxvectord, auxvectori)
2313 IF (icheck > 1 .OR. irank < ncon) THEN
2314 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, irank
2315 IF (irank < ncon) THEN
2316 WRITE(*,*) ' .. rank deficit !! '
2317 WRITE(*,*) ' E.g. fix all parameters and remove all constraints related to label ', &
2318 globalparlabelindex(1,globalparvartototal(ipar0+1))
2319 END IF
2320 END IF
2321 nrank=nrank+irank
2322 ioffc=ioffc+int(npar,mpl)*int(ncon,mpl)
2323 ioffp=ij
2324 END DO
2325
2326 nmiss1=ncgb-nrank
2327
2328 WRITE(*,*) ' '
2329 WRITE(*,*) 'Rank of product matrix of constraints is',nrank, &
2330 ' for',ncgb,' constraint equations'
2331 WRITE(8,*) 'Rank of product matrix of constraints is',nrank, &
2332 ' for',ncgb,' constraint equations'
2333 IF(nrank < ncgb) THEN
2334 WRITE(*,*) 'Warning: insufficient constraint equations!'
2335 WRITE(8,*) 'Warning: insufficient constraint equations!'
2336 IF (iforce == 0) THEN
2337 isubit=1
2338 WRITE(*,*) ' --> enforcing SUBITO mode'
2339 WRITE(8,*) ' --> enforcing SUBITO mode'
2340 END IF
2341 END IF
2342
2343 ! QL decomposition
2344 IF (nfgb < nvgb) THEN
2345 print *
2346 print *, 'QL decomposition of constraints matrix'
2347 ! monitor progress
2348 IF(monpg1 > 0) THEN
2349 WRITE(lunlog,*) 'QL decomposition of constraints matrix'
2350 CALL monini(lunlog,monpg1,monpg2)
2351 END IF
2352 IF(icelim < 2) THEN ! True unless unpacked LAPACK
2353 ! QL decomposition
2354 CALL qlini(nvgb,ncgb,npblck,mszcon,monpg1)
2355 ! loop over parameter blocks
2356 CALL qldecb(matconstraintst,matparblockoffsets,matconsblocks,matconsranges)
2357 ! check eignevalues of L
2358 CALL qlgete(evmin,evmax)
2359#ifdef LAPACK64
2360 ELSE
2361 CALL lpqldec(matconstraintst,evmin,evmax)
2362#endif
2363 END IF
2364 IF(monpg1 > 0) CALL monend()
2365 print *, ' largest |eigenvalue| of L: ', evmax
2366 print *, ' smallest |eigenvalue| of L: ', evmin
2367 IF (evmin == 0.0_mpd.AND.icheck == 0) THEN
2368 CALL peend(27,'Aborted, singular QL decomposition of constraints matrix')
2369 stop 'FEASMA: stopping due to singular QL decomposition of constraints matrix'
2370 END IF
2371 END IF
2372
2373 CALL mpdealloc(matconstraintst)
2374 CALL mpdealloc(auxvectord)
2375 CALL mpdealloc(auxvectori)
2376
2377 RETURN
2378END SUBROUTINE feasma ! matrix for feasible solution
2379
2387SUBROUTINE feasib(concut,iact)
2388 USE mpmod
2389 USE mpdalc
2390
2391 IMPLICIT NONE
2392 REAL(mpd) :: factr
2393 REAL(mpd) :: sgm
2394 INTEGER(mpi) :: i
2395 INTEGER(mpi) :: icgb
2396 INTEGER(mpi) :: icgrp
2397 INTEGER(mpi) :: iter
2398 INTEGER(mpi) :: itgbi
2399 INTEGER(mpi) :: ivgb
2400 INTEGER(mpi) :: ieblck
2401 INTEGER(mpi) :: isblck
2402 INTEGER(mpi) :: ifirst
2403 INTEGER(mpi) :: ilast
2404 INTEGER(mpi) :: j
2405 INTEGER(mpi) :: jcgb
2406 INTEGER(mpi) :: label
2407 INTEGER(mpi) :: inone
2408 INTEGER(mpi) :: ncon
2409
2410 REAL(mps), INTENT(IN) :: concut
2411 INTEGER(mpi), INTENT(OUT) :: iact
2412
2413 REAL(mpd) :: rhs
2414 REAL(mpd) ::sum1
2415 REAL(mpd) ::sum2
2416 REAL(mpd) ::sum3
2417
2418 REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecCorrections
2419 SAVE
2420
2421 iact=0
2422 IF(ncgb == 0) RETURN ! no constraints
2423
2424 DO iter=1,2
2425 vecconsresiduals=0.0_mpd
2426
2427 ! calculate right constraint equation discrepancies
2428 DO jcgb=1,ncgb
2429 icgb=matconssort(3,jcgb) ! unsorted constraint index
2430 i=vecconsstart(icgb)
2431 rhs=listconstraints(i )%value ! right hand side
2432 sgm=listconstraints(i+1)%value ! sigma parameter
2433 DO j=i+2,vecconsstart(icgb+1)-1
2434 label=listconstraints(j)%label
2435 factr=listconstraints(j)%value
2436 itgbi=inone(label) ! -> ITGBI= index of parameter label
2437 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2438 ENDDO
2439 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2440 END DO
2441
2442 ! constraint equation discrepancies -------------------------------
2443
2444 sum1=0.0_mpd
2445 sum2=0.0_mpd
2446 sum3=0.0_mpd
2447 DO icgb=1,ncgb
2448 sum1=sum1+vecconsresiduals(icgb)**2
2449 sum2=sum2+abs(vecconsresiduals(icgb))
2450 sum3=max(sum3,abs(vecconsresiduals(icgb)))
2451 END DO
2452 sum1=sqrt(sum1/real(ncgb,mpd))
2453 sum2=sum2/real(ncgb,mpd)
2454
2455 IF(iter == 1.AND.sum1 < concut) RETURN ! do nothing if correction small
2456
2457 IF(iter == 1.AND.ncgb <= 12) THEN
2458 WRITE(*,*) ' '
2459 WRITE(*,*) 'Constraint equation discrepancies:'
2460 WRITE(*,101) (icgb,vecconsresiduals(icgb),icgb=1,ncgb)
2461101 FORMAT(4x,4(i5,g12.4))
2462 WRITE(*,103) concut
2463103 FORMAT(10x,' Cut on rms value is',g8.1)
2464 END IF
2465
2466 IF(iact == 0) THEN
2467 WRITE(*,*) ' '
2468 WRITE(*,*) 'Improve constraints'
2469 END IF
2470 iact=1
2471
2472 WRITE(*,102) iter,sum1,sum2,sum3
2473102 FORMAT(i6,' rms',g12.4,' avrg_abs',g12.4,' max_abs',g12.4)
2474
2475 CALL mpalloc(veccorrections,int(nvgb,mpl),'constraint corrections')
2476 veccorrections=0.0_mpd
2477
2478 ! multiply (group-wise) inverse matrix and constraint vector
2479 isblck=0
2480 DO icgrp=1,ncgrp
2481 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2482 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2483 ncon=ilast+1-ifirst
2484 ieblck=isblck+(ncon*(ncon+1))/2
2485 CALL dbsvx(matconsproduct(isblck+1:ieblck),vecconsresiduals(ifirst:ilast),vecconssolution(ifirst:ilast),ncon)
2486 isblck=ieblck
2487 END DO
2488
2489 DO jcgb=1,ncgb
2490 icgb=matconssort(3,jcgb) ! unsorted constraint index
2491 i=vecconsstart(icgb)
2492 rhs=listconstraints(i )%value ! right hand side
2493 sgm=listconstraints(i+1)%value ! sigma parameter
2494 DO j=i+2,vecconsstart(icgb+1)-1
2495 label=listconstraints(j)%label
2496 factr=listconstraints(j)%value
2497 itgbi=inone(label) ! -> ITGBI= index of parameter label
2498 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2499 IF(ivgb > 0) THEN
2500 veccorrections(ivgb)=veccorrections(ivgb)+vecconssolution(jcgb)*factr
2501 END IF
2502 ENDDO
2503 END DO
2504
2505 DO i=1,nvgb ! add corrections
2506 itgbi=globalparvartototal(i)
2507 globalparameter(itgbi)=globalparameter(itgbi)+veccorrections(i)
2508 END DO
2509
2510 CALL mpdealloc(veccorrections)
2511
2512 END DO ! iteration 1 and 2
2513
2514END SUBROUTINE feasib ! make parameters feasible
2515
2548SUBROUTINE peread(more)
2549 USE mpmod
2550
2551 IMPLICIT NONE
2552 INTEGER(mpi) :: i
2553 INTEGER(mpi) :: iact
2554 INTEGER(mpi) :: ierrc
2555 INTEGER(mpi) :: ierrf
2556 INTEGER(mpi) :: ioffp
2557 INTEGER(mpi) :: ios
2558 INTEGER(mpi) :: ithr
2559 INTEGER(mpi) :: jfile
2560 INTEGER(mpi) :: jrec
2561 INTEGER(mpi) :: k
2562 INTEGER(mpi) :: kfile
2563 INTEGER(mpi) :: l
2564 INTEGER(mpi) :: lun
2565 INTEGER(mpi) :: mpri
2566 INTEGER(mpi) :: n
2567 INTEGER(mpi) :: nact
2568 INTEGER(mpi) :: nbuf
2569 INTEGER(mpi) :: ndata
2570 INTEGER(mpi) :: noff
2571 INTEGER(mpi) :: noffs
2572 INTEGER(mpi) :: npointer
2573 INTEGER(mpi) :: npri
2574 INTEGER(mpi) :: nr
2575 INTEGER(mpi) :: nrc
2576 INTEGER(mpi) :: nrd
2577 INTEGER(mpi) :: nrpr
2578 INTEGER(mpi) :: nthr
2579 INTEGER(mpi) :: ntot
2580 INTEGER(mpi) :: maxRecordSize
2581 INTEGER(mpi) :: maxRecordFile
2582
2583 INTEGER(mpi), INTENT(OUT) :: more
2584
2585 LOGICAL :: lprint
2586 LOGICAL :: floop
2587 LOGICAL :: eof
2588 REAL(mpd) :: ds0
2589 REAL(mpd) :: ds1
2590 REAL(mpd) :: ds2
2591 REAL(mpd) :: dw
2592 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
2593 CHARACTER (LEN=7) :: cfile
2594 SAVE
2595
2596#ifdef READ_C_FILES
2597 INTERFACE
2598 SUBROUTINE readc(bufferD, bufferF, bufferI, bufferLength, lun, err) BIND(c)
2599 USE iso_c_binding
2600 REAL(c_double), DIMENSION(*), INTENT(OUT) :: bufferD
2601 REAL(c_float), DIMENSION(*), INTENT(OUT) :: bufferF
2602 INTEGER(c_int), DIMENSION(*), INTENT(OUT) :: bufferI
2603 INTEGER(c_int), INTENT(INOUT) :: bufferLength
2604 INTEGER(c_int), INTENT(IN), VALUE :: lun
2605 INTEGER(c_int), INTENT(OUT) :: err
2606 END SUBROUTINE readc
2607 END INTERFACE
2608#endif
2609
2610 DATA lprint/.true./
2611 DATA floop/.true./
2612 DATA npri / 0 /, mpri / 1000 /
2613 ! ...
2614 IF(ifile == 0) THEN ! start/restart
2615 nrec=0
2616 nrecd=0
2617 ntot=0
2618 sumrecords=0
2619 skippedrecords=0
2620 numblocks=0
2621 minrecordsinblock=size(readbufferdatai)
2622 maxrecordsinblock=0
2623 readbufferinfo=0 ! reset management info
2624 nrpr=1
2625 nthr=mthrdr
2626 nact=0 ! active threads (have something still to read)
2627 DO k=1,nthr
2628 IF (ifile < nfilb) THEN
2629 ifile=ifile+1
2630 readbufferinfo(1,k)=ifile
2631 readbufferinfo(2,k)=nact
2632 nact=nact+1
2633 END IF
2634 END DO
2635 END IF
2636 npointer=size(readbufferpointer)/nact
2637 ndata=size(readbufferdatai)/nact
2638 more=-1
2639 DO k=1,nthr
2640 iact=readbufferinfo(2,k)
2641 readbufferinfo(4,k)=0 ! reset counter
2642 readbufferinfo(5,k)=iact*ndata ! reset offset
2643 END DO
2644 numblocks=numblocks+1 ! new block
2645
2646 !$OMP PARALLEL &
2647 !$OMP DEFAULT(PRIVATE) &
2648 !$OMP SHARED(readBufferInfo,readBufferPointer,readBufferDataI,readBufferDataD, &
2649 !$OMP readBufferDataF,nPointer,nData,skippedRecords,ndimbuf,NTHR,NFILF,FLOOP, &
2650 !$OMP IFD,KFD,IFILE,NFILB,WFD,XFD,icheck,keepOpen,ireeof,nrderr) &
2651 !$OMP NUM_THREADS(NTHR)
2652
2653 ithr=1
2654 !$ ITHR=OMP_GET_THREAD_NUM()+1 ! thread number
2655 jfile=readbufferinfo(1,ithr) ! file index
2656 iact =readbufferinfo(2,ithr) ! active thread number
2657 jrec =readbufferinfo(3,ithr) ! records read
2658 ioffp=iact*npointer
2659 noffs=(ithr-1)*ndimbuf ! offset for intermediate float buffer
2660
2661 files: DO WHILE (jfile > 0)
2662 kfile=kfd(2,jfile)
2663 ! open again
2664 IF (keepopen < 1 .AND. readbufferinfo(3,ithr) == 0) THEN
2665 CALL binopn(kfile,ithr,ios)
2666 END IF
2667 records: DO
2668 nbuf=readbufferinfo(4,ithr)+1
2669 noff=readbufferinfo(5,ithr)+2 ! 2 header words per record
2670 nr=ndimbuf
2671 IF(kfile <= nfilf) THEN ! Fortran file
2672 lun=kfile+10
2673 READ(lun,iostat=ierrf) n,(readbufferdataf(noffs+i),i=1,min(n/2,nr)),&
2674 (readbufferdatai(noff+i),i=1,min(n/2,nr))
2675 nr=n/2
2676 ! convert to double
2677 DO i=1,nr
2678 readbufferdatad(noff+i)=real(readbufferdataf(noffs+i),mpr8)
2679 END DO
2680 ! IF (ierrf < 0) REWIND lun ! end-of-file ! CHK use binrwd()
2681 eof=(ierrf /= 0)
2682 ELSE ! C file
2683 lun=kfile-nfilf
2684 IF (keepopen < 1) lun=ithr
2685#ifdef READ_C_FILES
2686 CALL readc(readbufferdatad(noff+1),readbufferdataf(noffs+1),readbufferdatai(noff+1),nr,lun,ierrc)
2687 n=nr+nr
2688 IF (ierrc > 4) readbufferinfo(6,ithr)=readbufferinfo(6,ithr)+1
2689#else
2690 ierrc=0
2691#endif
2692 eof=(ierrc <= 0.AND.ierrc /= -4) ! allow buffer overruns -> skip record
2693 IF(eof.AND.ierrc < 0) THEN
2694 WRITE(*,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2695 WRITE(8,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2696 IF (icheck <= 0 .AND. ireeof <=0) THEN ! stop unless 'checkinput' mode or 'readerroraseof'
2697 WRITE(cfile,'(I7)') kfile
2698 CALL peend(18,'Aborted, read error(s) for binary file ' // cfile)
2699 stop 'PEREAD: stopping due to read errors'
2700 END IF
2701 IF (kfd(1,jfile) == 1) THEN ! count files with read errors in first loop
2702 !$OMP ATOMIC
2703 nrderr=nrderr+1
2704 END IF
2705 END IF
2706 END IF
2707 IF(eof) EXIT records ! end-of-files or error
2708
2709 jrec=jrec+1
2710 readbufferinfo(3,ithr)=jrec
2711 IF(floop) THEN
2712 xfd(jfile)=max(xfd(jfile),n)
2713 IF(ithr == 1) THEN
2714 CALL hmplnt(1,n)
2715 IF(readbufferdatai(noff+1) /= 0) CALL hmpent(8,real(readbufferdatai(noff+1),mps))
2716 END IF
2717 END IF
2718
2719 IF (nr <= ndimbuf) THEN
2720 readbufferinfo(4,ithr)=nbuf
2721 readbufferinfo(5,ithr)=noff+nr
2722
2723 readbufferpointer(ioffp+nbuf)=noff ! pointer to start of buffer
2724 readbufferdatai(noff )=noff+nr ! pointer to end of buffer
2725 readbufferdatai(noff-1)=jrec ! local record number
2726 readbufferdatad(noff )=real(kfile,mpr8) ! file number
2727 readbufferdatad(noff-1)=real(wfd(kfile),mpr8) ! weight
2728
2729 IF ((noff+nr+2+ndimbuf >= ndata*(iact+1)).OR.(nbuf >= npointer)) EXIT files ! buffer full
2730 ELSE
2731 !$OMP ATOMIC
2732 skippedrecords=skippedrecords+1
2733 cycle records
2734 END IF
2735
2736 END DO records
2737
2738 readbufferinfo(1,ithr)=-jfile ! flag eof
2739 IF (keepopen < 1) THEN ! close again
2740 CALL bincls(kfile,ithr)
2741 ELSE ! rewind
2742 CALL binrwd(kfile)
2743 END IF
2744 IF (kfd(1,jfile) == 1) THEN
2745 print *, 'PEREAD: file ', kfile, 'read the first time, found',jrec,' records'
2746 kfd(1,jfile)=-jrec
2747 ELSE
2748 !PRINT *, 'PEREAD: file ', kfile, 'records', jrec, -kfd(1,jfile)
2749 IF (-kfd(1,jfile) /= jrec) THEN
2750 WRITE(cfile,'(I7)') kfile
2751 CALL peend(19,'Aborted, binary file modified (length) ' // cfile)
2752 stop 'PEREAD: file modified (length)'
2753 END IF
2754 END IF
2755 ! take next file
2756 !$OMP CRITICAL
2757 IF (ifile < nfilb) THEN
2758 ifile=ifile+1
2759 jrec=0
2760 readbufferinfo(1,ithr)=ifile
2761 readbufferinfo(3,ithr)=jrec
2762 END IF
2763 !$OMP END CRITICAL
2764 jfile=readbufferinfo(1,ithr)
2765
2766 END DO files
2767 !$OMP END PARALLEL
2768 ! compress pointers
2769 nrd=readbufferinfo(4,1) ! buffers from 1 .thread
2770 DO k=2,nthr
2771 iact =readbufferinfo(2,k)
2772 ioffp=iact*npointer
2773 nbuf=readbufferinfo(4,k)
2774 DO l=1,nbuf
2775 readbufferpointer(nrd+l)=readbufferpointer(ioffp+l)
2776 END DO
2777 nrd=nrd+nbuf
2778 END DO
2779
2780 more=0
2781 DO k=1,nthr
2782 jfile=readbufferinfo(1,k)
2783 IF (jfile > 0) THEN ! no eof yet
2784 readbufferinfo(2,k)=more
2785 more=more+1
2786 ELSE
2787 ! no more files, thread retires
2788 readbufferinfo(1,k)=0
2789 readbufferinfo(2,k)=-1
2790 readbufferinfo(3,k)=0
2791 nrecd=nrecd+readbufferinfo(6,k)
2792 readbufferinfo(6,k)=0
2793 END IF
2794 END DO
2795 ! record limit ?
2796 IF (mxrec > 0.AND.(ntot+nrd) >= mxrec) THEN
2797 nrd=mxrec-ntot
2798 more=-1
2799 DO k=1,nthr
2800 jfile=readbufferinfo(1,k)
2801 IF (jfile > 0) THEN ! rewind or close files
2802 nrc=readbufferinfo(3,k)
2803 IF (kfd(1,jfile) == 1) kfd(1,jfile)=-nrc
2804 kfile=kfd(2,jfile)
2805 IF (keepopen < 1) THEN ! close again
2806 CALL bincls(kfile,k)
2807 ELSE ! rewind
2808 CALL binrwd(kfile)
2809 END IF
2810 END IF
2811 END DO
2812 END IF
2813
2814 ntot=ntot+nrd
2815 nrec=ntot
2816 numreadbuffer=nrd
2817
2818 sumrecords=sumrecords+nrd
2819 minrecordsinblock=min(minrecordsinblock,nrd)
2820 maxrecordsinblock=max(maxrecordsinblock,nrd)
2821
2822 DO WHILE (nloopn == 0.AND.ntot >= nrpr)
2823 WRITE(*,*) ' Record ',nrpr
2824 IF (nrpr < 100000) THEN
2825 nrpr=nrpr*10
2826 ELSE
2827 nrpr=nrpr+100000
2828 END IF
2829 END DO
2830
2831 IF (ncache > 0.AND.nloopn <= 1.AND. npri < mpri.AND.mprint > 1) THEN
2832 npri=npri+1
2833 IF (npri == 1) WRITE(*,100)
2834 WRITE(*,101) nrec, nrd, more ,ifile
2835100 FORMAT(/' PeRead records active file' &
2836 /' total block threads number')
2837101 FORMAT(' PeRead',4i10)
2838 END IF
2839
2840 IF (more <= 0) THEN
2841 ifile=0
2842 IF (floop) THEN
2843 ! check for file weights
2844 ds0=0.0_mpd
2845 ds1=0.0_mpd
2846 ds2=0.0_mpd
2847 maxrecordsize=0
2848 maxrecordfile=0
2849 DO k=1,nfilb
2850 IF (xfd(k) > maxrecordsize) THEN
2851 maxrecordsize=xfd(k)
2852 maxrecordfile=k
2853 END IF
2854 dw=real(-kfd(1,k),mpd)
2855 IF (wfd(k) /= 1.0) nfilw=nfilw+1
2856 ds0=ds0+dw
2857 ds1=ds1+dw*real(wfd(k),mpd)
2858 ds2=ds2+dw*real(wfd(k)**2,mpd)
2859 END DO
2860 print *, 'PEREAD: file ', maxrecordfile, 'with max record size ', maxrecordsize
2861 IF (nfilw > 0.AND.ds0 > 0.0_mpd) THEN
2862 ds1=ds1/ds0
2863 ds2=ds2/ds0-ds1*ds1
2864 DO lun=6,lunlog,2
2865 WRITE(lun,177) nfilw,real(ds1,mps),real(ds2,mps)
2866177 FORMAT(/' !!!!!',i4,' weighted binary files', &
2867 /' !!!!! mean, variance of weights =',2g12.4)
2868 END DO
2869 END IF
2870 ! integrate record numbers
2871 DO k=2,nfilb
2872 ifd(k)=ifd(k-1)-kfd(1,k-1)
2873 END DO
2874 ! sort
2875 IF (nthr > 1) CALL sort2k(kfd,nfilb)
2876 IF (skippedrecords > 0) THEN
2877 print *, 'PEREAD skipped records: ', skippedrecords
2878 ndimbuf=maxrecordsize/2 ! adjust buffer size
2879 END IF
2880 END IF
2881 lprint=.false.
2882 floop=.false.
2883 IF (ncache > 0.AND.nloopn <= 1.AND.mprint > 0) &
2884 WRITE(*,179) numblocks, sumrecords, minrecordsinblock, maxrecordsinblock
2885179 FORMAT(/' Read cache usage (#blocks, #records, ', &
2886 'min,max records/block'/17x,i10,i12,2i10)
2887 END IF
2888 RETURN
2889
2890END SUBROUTINE peread
2891
2899SUBROUTINE peprep(mode)
2900 USE mpmod
2901
2902 IMPLICIT NONE
2903
2904 INTEGER(mpi), INTENT(IN) :: mode
2905
2906 INTEGER(mpi) :: ibuf
2907 INTEGER(mpi) :: ichunk
2908 INTEGER(mpi) :: ist
2909 INTEGER(mpi) :: itgbi
2910 INTEGER(mpi) :: j
2911 INTEGER(mpi) :: ja
2912 INTEGER(mpi) :: jb
2913 INTEGER(mpi) :: jsp
2914 INTEGER(mpi) :: nst
2915 INTEGER(mpi), PARAMETER :: maxbad = 100 ! max number of bad records with print out
2916 INTEGER(mpi) :: nbad
2917 INTEGER(mpi) :: nerr
2918 INTEGER(mpi) :: inone
2919
2920 IF (mode > 0) THEN
2921#ifdef __PGIC__
2922 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
2923 ichunk=256
2924#else
2925 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
2926#endif
2927 ! parallelize record loop
2928 !$OMP PARALLEL DO &
2929 !$OMP DEFAULT(PRIVATE) &
2930 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,ICHUNK,iscerr,dscerr) &
2931 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
2932 DO ibuf=1,numreadbuffer ! buffer for current record
2933 ist=readbufferpointer(ibuf)+1
2934 nst=readbufferdatai(readbufferpointer(ibuf))
2935 DO ! loop over measurements
2936 CALL isjajb(nst,ist,ja,jb,jsp)
2937 IF(jb == 0) EXIT
2938 DO j=1,ist-jb
2939 readbufferdatai(jb+j)=inone( readbufferdatai(jb+j) ) ! translate to index
2940 END DO
2941 ! scale error ?
2942 IF (iscerr > 0) THEN
2943 IF (jb < ist) THEN
2944 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(1) ! 'global' measurement
2945 ELSE
2946 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(2) ! 'local' measurement
2947 END IF
2948 END IF
2949 END DO
2950 END DO
2951 !$OMP END PARALLEL DO
2952 END IF
2953
2954 !$POMP INST BEGIN(peprep)
2955 IF (mode <= 0) THEN
2956 nbad=0
2957 DO ibuf=1,numreadbuffer ! buffer for current record
2958 CALL pechk(ibuf,nerr)
2959 IF(nerr > 0) THEN
2960 nbad=nbad+1
2961 IF(nbad >= maxbad) EXIT
2962 ELSE
2963 ist=readbufferpointer(ibuf)+1
2964 nst=readbufferdatai(readbufferpointer(ibuf))
2965 DO ! loop over measurements
2966 CALL isjajb(nst,ist,ja,jb,jsp)
2967 IF(jb == 0) EXIT
2968 neqn=neqn+1
2969 IF(jb == ist) cycle
2970 negb=negb+1
2971 ndgb=ndgb+(ist-jb)
2972 DO j=1,ist-jb
2973 itgbi=inone( readbufferdatai(jb+j) ) ! generate index
2974 END DO
2975 END DO
2976 END IF
2977 END DO
2978 IF(nbad > 0) THEN
2979 CALL peend(20,'Aborted, bad binary records')
2980 stop 'PEREAD: stopping due to bad records'
2981 END IF
2982 END IF
2983 !$POMP INST END(peprep)
2984
2985END SUBROUTINE peprep
2986
2994SUBROUTINE pechk(ibuf, nerr)
2995 USE mpmod
2996
2997 IMPLICIT NONE
2998 INTEGER(mpi) :: i
2999 INTEGER(mpi) :: is
3000 INTEGER(mpi) :: ist
3001 INTEGER(mpi) :: ioff
3002 INTEGER(mpi) :: ja
3003 INTEGER(mpi) :: jb
3004 INTEGER(mpi) :: jsp
3005 INTEGER(mpi) :: nan
3006 INTEGER(mpi) :: nst
3007
3008 INTEGER(mpi), INTENT(IN) :: ibuf
3009 INTEGER(mpi), INTENT(OUT) :: nerr
3010 SAVE
3011 ! ...
3012
3013 ist=readbufferpointer(ibuf)+1
3014 nst=readbufferdatai(readbufferpointer(ibuf))
3015 nerr=0
3016 is=ist
3017 jsp=0
3018 outer: DO WHILE(is < nst)
3019 ja=0
3020 jb=0
3021 inner1: DO
3022 is=is+1
3023 IF(is > nst) EXIT outer
3024 IF(readbufferdatai(is) == 0) EXIT inner1 ! found 1. marker
3025 END DO inner1
3026 ja=is
3027 inner2: DO
3028 is=is+1
3029 IF(is > nst) EXIT outer
3030 IF(readbufferdatai(is) == 0) EXIT inner2 ! found 2. marker
3031 END DO inner2
3032 jb=is
3033 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3034 ! special data
3035 jsp=jb ! pointer to special data
3036 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3037 cycle outer
3038 END IF
3039 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3040 is=is+1
3041 END DO
3042 END DO outer
3043 IF(is > nst) THEN
3044 ioff = readbufferpointer(ibuf)
3045 WRITE(*,100) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi)
3046100 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' is broken !!!')
3047 nerr=nerr+1
3048 ENDIF
3049 nan=0
3050 DO i=ist, nst
3051 IF(.NOT.(readbufferdatad(i) <= 0.0_mpr8).AND..NOT.(readbufferdatad(i) > 0.0_mpr8)) nan=nan+1
3052 END DO
3053 IF(nan > 0) THEN
3054 ioff = readbufferpointer(ibuf)
3055 WRITE(*,101) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi), nan
3056101 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' contains ', i6, ' NaNs !!!')
3057 nerr= nerr+2
3058 ENDIF
3059
3060END SUBROUTINE pechk
3061
3066SUBROUTINE pepgrp
3067 USE mpmod
3068 USE mpdalc
3069
3070 IMPLICIT NONE
3071
3072 INTEGER(mpi) :: ibuf
3073 INTEGER(mpi) :: ichunk
3074 INTEGER(mpi) :: iproc
3075 INTEGER(mpi) :: ioff
3076 INTEGER(mpi) :: ioffbi
3077 INTEGER(mpi) :: ist
3078 INTEGER(mpi) :: itgbi
3079 INTEGER(mpi) :: j
3080 INTEGER(mpi) :: ja
3081 INTEGER(mpi) :: jb
3082 INTEGER(mpi) :: jsp
3083 INTEGER(mpi) :: nalg
3084 INTEGER(mpi) :: nst
3085 INTEGER(mpi) :: inone
3086 INTEGER(mpl) :: length
3087 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
3088
3089 CALL useone ! make (INONE) usable
3090 globalparheader(-2)=-1 ! set flag to inhibit further updates
3091 ! need back index
3092 IF (mcount > 0) THEN
3093 length=globalparheader(-1)*mthrd
3094 CALL mpalloc(backindexusage,length,'global variable-index array')
3095 backindexusage=0
3096 END IF
3097
3098#ifdef __PGIC__
3099 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
3100 ichunk=256
3101#else
3102 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
3103#endif
3104 ! parallelize record loop
3105 !$OMP PARALLEL DO &
3106 !$OMP DEFAULT(PRIVATE) &
3107 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,backIndexUsage,globalParHeader,ICHUNK,MCOUNT) &
3108 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
3109 DO ibuf=1,numreadbuffer ! buffer for current record
3110 ist=readbufferpointer(ibuf)+1
3111 nst=readbufferdatai(readbufferpointer(ibuf))
3112 IF (mcount > 0) THEN
3113 ! count per record
3114 iproc=0
3115 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
3116 ioffbi=globalparheader(-1)*iproc
3117 nalg=0
3118 ioff=readbufferpointer(ibuf)
3119 DO ! loop over measurements
3120 CALL isjajb(nst,ist,ja,jb,jsp)
3121 IF(jb == 0) EXIT
3122 IF (ist > jb) THEN
3123 DO j=1,ist-jb
3124 itgbi=inone( readbufferdatai(jb+j) ) ! translate to index
3125 IF (backindexusage(ioffbi+itgbi) == 0) THEN
3126 nalg=nalg+1
3127 readbufferdatai(ioff+nalg)=itgbi
3128 backindexusage(ioffbi+itgbi)=nalg
3129 END IF
3130 END DO
3131 END IF
3132 END DO
3133 ! reset back index
3134 DO j=1,nalg
3135 itgbi=readbufferdatai(ioff+j)
3136 backindexusage(ioffbi+itgbi)=0
3137 END DO
3138 ! sort (record)
3139 CALL sort1k(readbufferdatai(ioff+1),nalg)
3140 readbufferdatai(ioff)=ioff+nalg
3141 ELSE
3142 ! count per equation
3143 DO ! loop over measurements
3144 CALL isjajb(nst,ist,ja,jb,jsp)
3145 IF(jb == 0) EXIT
3146 IF (ist > jb) THEN
3147 DO j=1,ist-jb
3148 readbufferdatai(jb+j)=inone( readbufferdatai(jb+j) ) ! translate to index
3149 END DO
3150 ! sort (equation)
3151 CALL sort1k(readbufferdatai(jb+1),ist-jb)
3152 END IF
3153 END DO
3154 END IF
3155 END DO
3156 !$OMP END PARALLEL DO
3157
3158 !$POMP INST BEGIN(pepgrp)
3159 DO ibuf=1,numreadbuffer ! buffer for current record
3160 ist=readbufferpointer(ibuf)+1
3161 nst=readbufferdatai(readbufferpointer(ibuf))
3162 IF (mcount == 0) THEN
3163 ! equation level
3164 DO ! loop over measurements
3165 CALL isjajb(nst,ist,ja,jb,jsp)
3166 IF(jb == 0) EXIT
3167 CALL pargrp(jb+1,ist)
3168 END DO
3169 ELSE
3170 ! record level, group
3171 CALL pargrp(ist,nst)
3172 ENDIF
3173 END DO
3174 ! free back index
3175 IF (mcount > 0) THEN
3176 CALL mpdealloc(backindexusage)
3177 END IF
3178 !$POMP INST END(pepgrp)
3179 globalparheader(-2)=0 ! reset flag to reenable further updates
3180
3181END SUBROUTINE pepgrp
3182
3190SUBROUTINE pargrp(inds,inde)
3191 USE mpmod
3192
3193 IMPLICIT NONE
3194
3195 INTEGER(mpi) :: istart
3196 INTEGER(mpi) :: itgbi
3197 INTEGER(mpi) :: j
3198 INTEGER(mpi) :: jstart
3199 INTEGER(mpi) :: jtgbi
3200 INTEGER(mpi) :: lstart
3201 INTEGER(mpi) :: ltgbi
3202
3203 INTEGER(mpi), INTENT(IN) :: inds
3204 INTEGER(mpi), INTENT(IN) :: inde
3205
3206 IF (inds > inde) RETURN
3207
3208 ltgbi=-1
3209 lstart=-1
3210 ! build up groups
3211 DO j=inds,inde
3212 itgbi=readbufferdatai(j)
3213 ! count entries
3214 globalparlabelcounter(itgbi)=globalparlabelcounter(itgbi)+1
3215 istart=globalparlabelindex(3,itgbi) ! label of group start
3216 IF (istart == 0) THEN ! not yet in group
3217 IF (itgbi /= ltgbi+1) THEN ! start group
3218 globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)
3219 ELSE
3220 IF (lstart == 0) THEN ! extend group
3221 globalparlabelindex(3,itgbi)=globalparlabelindex(3,ltgbi)
3222 ELSE ! start group
3223 globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)
3224 END IF
3225 END IF
3226 END IF
3227 ltgbi=itgbi
3228 lstart=istart
3229 END DO
3230 ! split groups:
3231 ! - start inside group?
3232 itgbi=readbufferdatai(inds)
3233 istart=globalparlabelindex(3,itgbi) ! label of group start
3234 jstart=globalparlabelindex(1,itgbi) ! label of first parameter
3235 IF (istart /= jstart) THEN ! start new group
3236 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3237 globalparlabelindex(3,itgbi) = jstart
3238 itgbi=itgbi+1
3239 IF (itgbi > globalparheader(-1)) EXIT
3240 END DO
3241 END IF
3242 ! - not neigbours anymore
3243 ltgbi=readbufferdatai(inds)
3244 DO j=inds+1,inde
3245 itgbi=readbufferdatai(j)
3246 IF (itgbi /= ltgbi+1) THEN
3247 ! split after ltgbi
3248 lstart=globalparlabelindex(3,ltgbi) ! label of last group start
3249 jtgbi=ltgbi+1 ! new group after ltgbi
3250 jstart=globalparlabelindex(1,jtgbi)
3251 DO WHILE (globalparlabelindex(3,jtgbi) == lstart)
3252 globalparlabelindex(3,jtgbi) = jstart
3253 jtgbi=jtgbi+1
3254 IF (jtgbi > globalparheader(-1)) EXIT
3255 IF (jtgbi == itgbi) jstart=globalparlabelindex(1,jtgbi)
3256 END DO
3257 ! split at itgbi
3258 jtgbi=itgbi
3259 istart=globalparlabelindex(3,jtgbi) ! label of group start
3260 jstart=globalparlabelindex(1,jtgbi) ! label of first parameter
3261 IF (istart /= jstart) THEN ! start new group
3262 DO WHILE (globalparlabelindex(3,jtgbi) == istart)
3263 globalparlabelindex(3,jtgbi) = jstart
3264 jtgbi=jtgbi+1
3265 IF (jtgbi > globalparheader(-1)) EXIT
3266 END DO
3267 END IF
3268 ENDIF
3269 ltgbi=itgbi
3270 END DO
3271 ! - end inside group?
3272 itgbi=readbufferdatai(inde)
3273 IF (itgbi < globalparheader(-1)) THEN
3274 istart=globalparlabelindex(3,itgbi) ! label of group start
3275 itgbi=itgbi+1
3276 jstart=globalparlabelindex(1,itgbi) ! label of new group start
3277 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3278 globalparlabelindex(3,itgbi) = jstart
3279 itgbi=itgbi+1
3280 IF (itgbi > globalparheader(-1)) EXIT
3281 END DO
3282 END IF
3283
3284END SUBROUTINE pargrp
3285
3308SUBROUTINE isjajb(nst,is,ja,jb,jsp)
3309 USE mpmod
3310
3311 IMPLICIT NONE
3312
3313 INTEGER(mpi), INTENT(IN) :: nst
3314 INTEGER(mpi), INTENT(IN OUT) :: is
3315 INTEGER(mpi), INTENT(OUT) :: ja
3316 INTEGER(mpi), INTENT(OUT) :: jb
3317 INTEGER(mpi), INTENT(OUT) :: jsp
3318 SAVE
3319 ! ...
3320
3321 jsp=0
3322 DO
3323 ja=0
3324 jb=0
3325 IF(is >= nst) RETURN
3326 DO
3327 is=is+1
3328 IF(readbufferdatai(is) == 0) EXIT
3329 END DO
3330 ja=is
3331 DO
3332 is=is+1
3333 IF(readbufferdatai(is) == 0) EXIT
3334 END DO
3335 jb=is
3336 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3337 ! special data
3338 jsp=jb ! pointer to special data
3339 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3340 cycle
3341 END IF
3342 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3343 is=is+1
3344 END DO
3345 EXIT
3346 END DO
3347
3348END SUBROUTINE isjajb
3349
3350
3351!***********************************************************************
3352! LOOPN ...
3358
3359SUBROUTINE loopn
3360 USE mpmod
3361
3362 IMPLICIT NONE
3363 REAL(mpd) :: dsum
3364 REAL(mps) :: elmt
3365 REAL(mpd) :: factrj
3366 REAL(mpd) :: factrk
3367 REAL(mps) :: peakd
3368 REAL(mps) :: peaki
3369 REAL(mps) :: ratae
3370 REAL(mpd) :: rhs
3371 REAL(mps) :: rloop
3372 REAL(mpd) :: sgm
3373 REAL(mps) :: used
3374 REAL(mps) :: usei
3375 REAL(mpd) :: weight
3376 INTEGER(mpi) :: i
3377 INTEGER(mpi) :: ia
3378 INTEGER(mpi) :: ib
3379 INTEGER(mpi) :: ioffb
3380 INTEGER(mpi) :: ipr
3381 INTEGER(mpi) :: itgbi
3382 INTEGER(mpi) :: itgbij
3383 INTEGER(mpi) :: itgbik
3384 INTEGER(mpi) :: ivgb
3385 INTEGER(mpi) :: ivgbij
3386 INTEGER(mpi) :: ivgbik
3387 INTEGER(mpi) :: j
3388 INTEGER(mpi) :: k
3389 INTEGER(mpi) :: lastit
3390 INTEGER(mpi) :: lun
3391 INTEGER(mpi) :: ncrit
3392 INTEGER(mpi) :: ngras
3393 INTEGER(mpi) :: nparl
3394 INTEGER(mpi) :: nr
3395 INTEGER(mpi) :: nrej
3396 INTEGER(mpi) :: inone
3397 INTEGER(mpi) :: ilow
3398 INTEGER(mpi) :: nlow
3399 INTEGER(mpi) :: nzero
3400 LOGICAL :: btest
3401
3402 REAL(mpd):: adder
3403 REAL(mpd)::funref
3404 REAL(mpd)::matij
3405
3406 SAVE
3407 ! ...
3408
3409 ! ----- book and reset ---------------------------------------------
3410 IF(nloopn == 0) THEN ! first call
3411 lastit=-1
3412 iitera=0
3413 END IF
3414
3415 nloopn=nloopn+1 ! increase loop counter
3416 funref=0.0_mpd
3417
3418 IF(nloopn == 1) THEN ! book histograms for 1. iteration
3419 CALL gmpdef(1,4,'Function value in iterations')
3420 IF (metsol == 4 .OR. metsol == 5) THEN ! extend to GMRES, i.e. 6?
3421 CALL gmpdef(2,3,'Number of MINRES steps vs iteration nr')
3422 END IF
3423 CALL hmpdef( 5,0.0,0.0,'Number of degrees of freedom')
3424 CALL hmpdef(11,0.0,0.0,'Number of local parameters')
3425 CALL hmpdef(23,0.0,0.0, 'SQRT of diagonal elements without presigma')
3426 CALL hmpdef(24,0.0,0.0, 'Log10 of off-diagonal elements')
3427 CALL hmpdef(25,0.0,0.0, 'Relative individual pre-sigma')
3428 CALL hmpdef(26,0.0,0.0, 'Relative global pre-sigma')
3429 END IF
3430
3431
3432 CALL hmpdef(3,-prange,prange, & ! book
3433 'Normalized residuals of single (global) measurement')
3434 CALL hmpdef(12,-prange,prange, & ! book
3435 'Normalized residuals of single (local) measurement')
3436 CALL hmpdef(13,-prange,prange, & ! book
3437 'Pulls of single (global) measurement')
3438 CALL hmpdef(14,-prange,prange, & ! book
3439 'Pulls of single (local) measurement')
3440 CALL hmpdef(4,0.0,0.0,'Chi^2/Ndf after local fit')
3441 CALL gmpdef(4,5,'location, dispersion (res.) vs record nr')
3442 CALL gmpdef(5,5,'location, dispersion (pull) vs record nr')
3443
3444 ! WRITE(*,*) 'LOOPN ', NLOOPN, ' executing ICALCM=', ICALCM
3445
3446 ! reset
3447
3448 globalvector=0.0_mpd ! reset rhs vector IGVEC
3449 globalcounter=0
3450 IF(icalcm == 1) THEN
3451 globalmatd=0.0_mpd
3452 globalmatf=0.
3453 IF (metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) matprecond=0.0_mpd
3454 END IF
3455
3456 IF(nloopn == 2) CALL hmpdef(6,0.0,0.0,'Down-weight fraction')
3457
3458 newite=.false.
3459 IF(iterat /= lastit) THEN ! new iteration
3460 newite=.true.
3461 funref=fvalue
3462 IF(nloopn > 1) THEN
3463 nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3)
3464 ! CALL MEND
3465 IF(iterat == 1) THEN
3466 chicut=chirem
3467 ELSE IF(iterat >= 1) THEN
3468 chicut=sqrt(chicut)
3469 IF(chicut /= 0.0.AND.chicut < 1.5) chicut=1.0
3470 IF(chicut /= 0.0.AND.nrej == 0) chicut=1.0
3471 END IF
3472 END IF
3473 ! WRITE(*,111) ! header line
3474 END IF
3475
3476 DO i=0,3
3477 nrejec(i)=0 ! reset reject counter
3478 END DO
3479 DO k=3,6
3480 writebufferheader(k)=0 ! cache usage
3481 writebufferheader(-k)=0
3482 END DO
3483 ! statistics per binary file
3484 DO i=1,nfilb
3485 jfd(i)=0
3486 cfd(i)=0.0
3487 dfd(i)=0
3488 END DO
3489
3490 IF (imonit /= 0) meashists=0 ! reset monitoring histograms
3491
3492 ! ----- read next data ----------------------------------------------
3493 DO
3494 CALL peread(nr) ! read records
3495 CALL peprep(1) ! prepare records
3496 CALL loopbf(nrejec,nfiles,jfd,cfd,dfd)
3497 IF (nr <= 0) EXIT ! next block of events ?
3498 END DO
3499 ! sum up RHS (over threads) once (reduction in LOOPBF: summation for each block)
3500 ioffb=0
3501 DO ipr=2,mthrd
3502 ioffb=ioffb+lenglobalvec
3503 DO k=1,lenglobalvec
3504 globalvector(k)=globalvector(k)+globalvector(ioffb+k)
3505 globalcounter(k)=globalcounter(k)+globalcounter(ioffb+k)
3506 END DO
3507 END DO
3508
3509 IF (icalcm == 1) THEN
3510 ! PRINT *, ' cache/w ',(writeBufferHeader(-K),K=3,6),(writeBufferHeader(K),K=3,6)
3511 nparl=writebufferheader(3)
3512 ncrit=writebufferheader(4)
3513 used=real(writebufferheader(-5),mps)/real(writebufferheader(-3),mps)*0.1
3514 usei=real(writebufferheader(5),mps)/real(writebufferheader(3),mps)*0.1
3515 peakd=real(writebufferheader(-6),mps)*0.1
3516 peaki=real(writebufferheader(6),mps)*0.1
3517 WRITE(*,111) nparl,ncrit,usei,used,peaki,peakd
3518111 FORMAT(' Write cache usage (#flush,#overrun,<levels>,', &
3519 'peak(levels))'/2i7,',',4(f6.1,'%'))
3520 ! fill part of MINRES preconditioner matrix from binary files (formerly in mgupdt)
3521 IF (metsol >= 4.AND.metsol < 7) THEN
3522 IF (mbandw == 0) THEN
3523 ! default preconditioner (diagonal)
3524 DO i=1, nvgb
3525 matprecond(i)=matij(i,i)
3526 END DO
3527 ELSE IF (mbandw > 0) THEN
3528 ! band matrix
3529 DO i=1, nvgb
3530 ia=indprecond(i) ! index of diagonal element
3531 DO j=max(1,i-mbandw+1),i
3532 matprecond(ia-i+j)=matij(i,j)
3533 END DO
3534 END DO
3535 END IF
3536 END IF
3537 IF (ichkpg > 0) THEN
3538 ! check parameter groups
3539 CALL ckpgrp
3540 END IF
3541 END IF
3542
3543 ! check entries/counters
3544 nlow=0
3545 ilow=1
3546 nzero=0
3547 DO i=1,nvgb
3548 IF(globalcounter(i) == 0) nzero=nzero+1
3549 IF(globalcounter(i) < mreqena) THEN
3550 nlow=nlow+1
3551 IF(globalcounter(i) < globalcounter(ilow)) ilow=i
3552 END IF
3553 END DO
3554 IF(nlow > 0) THEN
3555 nalow=nalow+nlow
3556 IF(icalcm == 1) nxlow=max(nxlow,nlow) ! for matrix construction ?
3557 itgbi=globalparvartototal(ilow)
3558 print *
3559 print *, " ... warning ..."
3560 print *, " global parameters with too few (< MREQENA) accepted entries: ", nlow
3561 print *, " minimum entries: ", globalcounter(ilow), " for label ", globalparlabelindex(1,itgbi)
3562 print *
3563 END IF
3564 IF(icalcm == 1 .AND. nzero > 0) THEN
3565 ndefec = nzero ! rank defect
3566 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfgb, &
3567 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3568 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb, &
3569 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3570 IF (iforce == 0) THEN
3571 isubit=1
3572 WRITE(*,*) ' --> enforcing SUBITO mode'
3573 WRITE(lun,*) ' --> enforcing SUBITO mode'
3574 END IF
3575 END IF
3576
3577 ! ----- after end-of-data add contributions from pre-sigma ---------
3578
3579 IF(nloopn == 1) THEN
3580 ! plot diagonal elements
3581 elmt=0.0
3582 DO i=1,nvgb ! diagonal elements
3583 elmt=real(matij(i,i),mps)
3584 IF(elmt > 0.0) CALL hmpent(23,1.0/sqrt(elmt))
3585 END DO
3586 END IF
3587
3588
3589
3590 ! add pre-sigma contributions to matrix diagonal
3591
3592 ! WRITE(*,*) 'Adding to diagonal ICALCM IND6',ICALCM,IND6
3593
3594 IF(icalcm == 1) THEN
3595 DO ivgb=1,nvgb ! add evtl. pre-sigma
3596 ! WRITE(*,*) 'Index ',IVGB,IVGB,QM(IND6+IVGB)
3597 IF(globalparpreweight(ivgb) /= 0.0) THEN
3598 IF(ivgb > 0) CALL mupdat(ivgb,ivgb,globalparpreweight(ivgb))
3599 END IF
3600 END DO
3601 END IF
3602
3603 CALL hmpwrt(23)
3604 CALL hmpwrt(24)
3605 CALL hmpwrt(25)
3606 CALL hmpwrt(26)
3607
3608
3609 ! add regularization term to F and to rhs --------------------------
3610
3611 ! WRITE(*,*) 'NREGUL ',NREGUL,NLOOPN
3612
3613 IF(nregul /= 0) THEN ! add regularization term to F and to rhs
3614 DO ivgb=1,nvgb
3615 itgbi=globalparvartototal(ivgb) ! global parameter index
3616 globalvector(ivgb)=globalvector(ivgb) -globalparameter(itgbi)*globalparpreweight(ivgb)
3617 adder=globalparpreweight(ivgb)*globalparameter(itgbi)**2
3618 CALL addsums(1, adder, 0, 1.0_mpl)
3619 END DO
3620 END IF
3621
3622
3623 ! ----- add contributions from "measurement" -----------------------
3624
3625
3626 i=1
3627 DO WHILE (i <= lenmeasurements)
3628 rhs=listmeasurements(i )%value ! right hand side
3629 sgm=listmeasurements(i+1)%value ! sigma parameter
3630 i=i+2
3631 weight=0.0
3632 IF(sgm > 0.0) weight=1.0/sgm**2
3633
3634 dsum=-rhs
3635
3636 ! loop over label/factor pairs
3637 ia=i
3638 DO
3639 i=i+1
3640 IF(i > lenmeasurements) EXIT
3641 IF(listmeasurements(i)%label < 0) EXIT
3642 END DO
3643 ib=i-1
3644
3645 DO j=ia,ib
3646 factrj=listmeasurements(j)%value
3647 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3648 IF(itgbij /= 0) THEN
3649 dsum=dsum+factrj*globalparameter(itgbij) ! update residuum
3650 END IF
3651 END DO
3652 DO j=ia,ib
3653 factrj=listmeasurements(j)%value
3654 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3655 ! add to vector
3656 ivgbij=0
3657 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
3658 IF(ivgbij > 0) THEN
3659 globalvector(ivgbij)=globalvector(ivgbij) -weight*dsum*factrj ! vector
3660 globalcounter(ivgbij)=globalcounter(ivgbij)+1
3661 END IF
3662
3663 IF(icalcm == 1.AND.ivgbij > 0) THEN
3664 DO k=ia,j
3665 factrk=listmeasurements(k)%value
3666 itgbik=inone(listmeasurements(k)%label) ! total parameter index
3667 ! add to matrix
3668 ivgbik=0
3669 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
3670 IF(ivgbij > 0.AND.ivgbik > 0) THEN !
3671 CALL mupdat(ivgbij,ivgbik,weight*factrj*factrk)
3672 END IF
3673 END DO
3674 END IF
3675 END DO
3676
3677 adder=weight*dsum**2
3678 CALL addsums(1, adder, 1, 1.0_mpl)
3679
3680 END DO
3681
3682 ! ----- printout ---------------------------------------------------
3683
3684
3685 ! get accurate sum (Chi^2, (w)NDF)
3686 CALL getsums(fvalue,ndfsum,sumndf)
3687
3688 flines=0.5_mpd*fvalue ! Likelihood function value
3689 rloop=iterat+0.01*nloopn
3690 actfun=real(funref-fvalue,mps)
3691 IF(nloopn == 1) actfun=0.0
3692 ngras=nint(angras,mpi)
3693 ratae=0.0 !!!
3694 IF(delfun /= 0.0) THEN
3695 ratae=min(99.9,actfun/delfun) !!!
3696 ratae=max(-99.9,ratae)
3697 END IF
3698
3699 ! rejects ...
3700
3701 nrej =nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3)
3702 IF(nloopn == 1) THEN
3703 IF(nrej /= 0) THEN
3704 WRITE(*,*) ' '
3705 WRITE(*,*) 'Data rejected in initial loop:'
3706 WRITE(*,*) ' ', &
3707 nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', &
3708 nrejec(2), ' (huge) ',nrejec(3),' (large)'
3709 END IF
3710 END IF
3711 ! IF(NREJEC(1)+NREJEC(2)+NREJEC(3).NE.0) THEN
3712 ! WRITE(LUNLOG,*) 'Data rejected in initial loop:',NREJEC(1),
3713 ! + ' (Ndf=0) ',NREJEC(2),' (huge) ',NREJEC(3),' (large)'
3714 ! END IF
3715
3716
3717 IF(newite.AND.iterat == 2) THEN
3718 IF(nrecpr /= 0.OR.nrecp2 /= 0) nrecer=nrec3
3719 IF(nrecpr < 0) THEN
3720 nrecpr=nrec1
3721 END IF
3722 IF(nrecp2 < 0) THEN
3723 nrecp2=nrec2
3724 END IF
3725 END IF
3726
3727 IF(nloopn <= 2) THEN
3728 IF(nhistp /= 0) THEN
3729 ! CALL HMPRNT(3) ! scaled residual of single measurement
3730 ! CALL HMPRNT(12) ! scaled residual of single measurement
3731 ! CALL HMPRNT(4) ! chi^2/Ndf
3732 END IF
3733 CALL hmpwrt(3)
3734 CALL hmpwrt(12)
3735 CALL hmpwrt(4)
3736 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
3737 IF (nloopn <= lfitnp) THEN
3738 CALL hmpwrt(13)
3739 CALL hmpwrt(14)
3740 CALL gmpwrt(5) ! location, dispersion (pull) as a function of record nr
3741 END IF
3742 END IF
3743 ! IF(NLOOPN.EQ.2.AND.NHISTP.NE.0) CALL HMPRNT(6)
3744 IF(nloopn == 2) CALL hmpwrt(6)
3745 IF(nloopn <= 1) THEN
3746 ! IF(NHISTP.NE.0) CALL HMPRNT(5) ! number of degrees of freedom
3747 ! IF(NHISTP.NE.0) CALL HMPRNT(11) ! Nlocal
3748 CALL hmpwrt(5)
3749 CALL hmpwrt(11)
3750 END IF
3751
3752 ! local fit: band matrix structure !?
3753 IF (nloopn == 1.AND.nbndr(1)+nbndr(2) > 0) THEN
3754 DO lun=6,8,2
3755 WRITE(lun,*) ' '
3756 WRITE(lun,*) ' === local fits have bordered band matrix structure ==='
3757 IF (nbndr(1) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(1),'number of records (upper/left border)'
3758 IF (nbndr(2) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(2),'number of records (lower/right border)'
3759 WRITE(lun,101) ' NBDRX',nbdrx,'max border size'
3760 WRITE(lun,101) ' NBNDX',nbndx,'max band width'
3761 END DO
3762 END IF
3763
3764 lastit=iterat
3765
3766 ! monitoring of residuals
3767 IF (imonit < 0 .OR. (nloopn == 1 .AND. btest(imonit,0))) CALL monres
3768
3769101 FORMAT(1x,a8,' =',i14,' = ',a)
3770! 101 FORMAT(' LOOPN',I6,' Function value',F22.8,10X,I6,' records')
3771! 102 FORMAT(' incl. constraint penalty',F22.8)
3772! 103 FORMAT(I13,3X,A,G12.4)
3773END SUBROUTINE loopn ! loop with fits
3774
3778
3779SUBROUTINE ploopa(lunp)
3780 USE mpmod
3781
3782 IMPLICIT NONE
3783
3784 INTEGER(mpi), INTENT(IN) :: lunp
3785 ! ..
3786 WRITE(lunp,*) ' '
3787 WRITE(lunp,101) ! header line
3788 WRITE(lunp,102) ! header line
3789101 FORMAT(' it fc',' fcn_value dfcn_exp slpr costh iit st', &
3790 ' ls step cutf',1x,'rejects hhmmss FMS')
3791102 FORMAT(' -- --',' ----------- -------- ---- ----- --- --', &
3792 ' -- ----- ----',1x,'------- ------ ---')
3793 RETURN
3794END SUBROUTINE ploopa ! title for iteration
3795
3799
3800SUBROUTINE ploopb(lunp)
3801 USE mpmod
3802
3803 IMPLICIT NONE
3804 INTEGER(mpi) :: ma
3805 INTEGER :: minut
3806 INTEGER(mpi) :: nfa
3807 INTEGER :: nhour
3808 INTEGER(mpi) :: nrej
3809 INTEGER(mpi) :: nsecnd
3810 REAL(mps) :: ratae
3811 REAL :: rstb
3812 REAL(mps) :: secnd
3813 REAL(mps) :: slopes(3)
3814 REAL(mps) :: steps(3)
3815 REAL, DIMENSION(2) :: ta
3816 REAl etime
3817
3818 INTEGER(mpi), INTENT(IN) :: lunp
3819
3820 CHARACTER (LEN=4):: ccalcm(4)
3821 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3822 SAVE
3823
3824 nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! rejects
3825 IF(nrej > 9999999) nrej=9999999
3826 rstb=etime(ta)
3827 deltim=rstb-rstart
3828 CALL sechms(deltim,nhour,minut,secnd) ! time
3829 nsecnd=nint(secnd,mpi)
3830 IF(iterat == 0) THEN
3831 WRITE(lunp,103) iterat,nloopn,fvalue, &
3832 chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3833 ELSE
3834 IF (lsinfo == 10) THEN ! line search skipped
3835 WRITE(lunp,105) iterat,nloopn,fvalue,delfun, &
3836 iitera,istopa,chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3837 ELSE
3838 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3839 ratae=max(-99.9,min(99.9,slopes(2)/slopes(1)))
3840 stepl=steps(2)
3841 WRITE(lunp,104) iterat,nloopn,fvalue,delfun,ratae,angras, &
3842 iitera,istopa,lsinfo,stepl, chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3843 ENDIF
3844 END IF
3845103 FORMAT(i3,i3,e12.5,38x,f5.1, 1x,i7, i3,i2.2,i2.2,a4)
3846104 FORMAT(i3,i3,e12.5,1x,e8.2,f6.3,f6.3,i5,2i3,f6.3,f5.1, &
3847 1x,i7, i3,i2.2,i2.2,a4)
3848105 FORMAT(i3,i3,e12.5,1x,e8.2,12x,i5,i3,9x,f5.1, &
3849 1x,i7, i3,i2.2,i2.2,a4)
3850 RETURN
3851END SUBROUTINE ploopb ! iteration line
3852
3856
3857SUBROUTINE ploopc(lunp)
3858 USE mpmod
3859
3860 IMPLICIT NONE
3861 INTEGER(mpi) :: ma
3862 INTEGER(mpi) :: minut
3863 INTEGER(mpi) :: nfa
3864 INTEGER(mpi) :: nhour
3865 INTEGER(mpi) :: nrej
3866 INTEGER(mpi) :: nsecnd
3867 REAL(mps) :: ratae
3868 REAL :: rstb
3869 REAL(mps) :: secnd
3870 REAL(mps) :: slopes(3)
3871 REAL(mps) :: steps(3)
3872 REAL, DIMENSION(2) :: ta
3873 REAL etime
3874
3875 INTEGER(mpi), INTENT(IN) :: lunp
3876 CHARACTER (LEN=4):: ccalcm(4)
3877 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3878 SAVE
3879
3880 nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! rejects
3881 IF(nrej > 9999999) nrej=9999999
3882 rstb=etime(ta)
3883 deltim=rstb-rstart
3884 CALL sechms(deltim,nhour,minut,secnd) ! time
3885 nsecnd=nint(secnd,mpi)
3886 IF (lsinfo == 10) THEN ! line search skipped
3887 WRITE(lunp,104) nloopn,fvalue,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3888 ELSE
3889 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3890 ratae=abs(slopes(2)/slopes(1))
3891 stepl=steps(2)
3892 WRITE(lunp,105) nloopn,fvalue, ratae,lsinfo, &
3893 stepl,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3894 END IF
3895104 FORMAT(3x,i3,e12.5,9x, 35x, i7, i3,i2.2,i2.2,a4)
3896105 FORMAT(3x,i3,e12.5,9x, f6.3,14x,i3,f6.3,6x, i7, i3,i2.2,i2.2,a4)
3897 RETURN
3898
3899END SUBROUTINE ploopc ! sub-iteration line
3900
3904
3905SUBROUTINE ploopd(lunp)
3906 USE mpmod
3907 IMPLICIT NONE
3908 INTEGER :: minut
3909 INTEGER :: nhour
3910 INTEGER(mpi) :: nsecnd
3911 REAL :: rstb
3912 REAL(mps) :: secnd
3913 REAL, DIMENSION(2) :: ta
3914 REAL etime
3915
3916 INTEGER(mpi), INTENT(IN) :: lunp
3917 CHARACTER (LEN=4):: ccalcm(4)
3918 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3919 SAVE
3920 rstb=etime(ta)
3921 deltim=rstb-rstart
3922 CALL sechms(deltim,nhour,minut,secnd) ! time
3923 nsecnd=nint(secnd,mpi)
3924
3925 WRITE(lunp,106) nhour,minut,nsecnd,ccalcm(lcalcm)
3926106 FORMAT(69x,i3,i2.2,i2.2,a4)
3927 RETURN
3928END SUBROUTINE ploopd
3929
3931SUBROUTINE explfc(lunit)
3932 USE mpdef
3933 USE mpmod, ONLY: metsol
3934
3935 IMPLICIT NONE
3936 INTEGER(mpi) :: lunit
3937 WRITE(lunit,*) ' '
3938 WRITE(lunit,102) 'Explanation of iteration table'
3939 WRITE(lunit,102) '=============================='
3940 WRITE(lunit,101) 'it', &
3941 'iteration number. Global parameters are improved for it > 0.'
3942 WRITE(lunit,102) 'First function evaluation is called iteraton 0.'
3943 WRITE(lunit,101) 'fc', 'number of function evaluations.'
3944 WRITE(lunit,101) 'fcn_value', 'value of 2 x Likelihood function (LF).'
3945 WRITE(lunit,102) 'The final value is the chi^2 value of the fit and should'
3946 WRITE(lunit,102) 'be about equal to the NDF (see below).'
3947 WRITE(lunit,101) 'dfcn_exp', &
3948 'expected reduction of the value of the Likelihood function (LF)'
3949 WRITE(lunit,101) 'slpr', 'ratio of the actual slope to inital slope.'
3950 WRITE(lunit,101) 'costh', &
3951 'cosine of angle between search direction and -gradient'
3952 IF (metsol == 4) THEN
3953 WRITE(lunit,101) 'iit', &
3954 'number of internal iterations in MINRES algorithm'
3955 WRITE(lunit,101) 'st', 'stop code of MINRES algorithm'
3956 WRITE(lunit,102) '< 0: rhs is very special, with beta2 = 0'
3957 WRITE(lunit,102) '= 0: rhs b = 0, i.e. the exact solution is x = 0'
3958 WRITE(lunit,102) '= 1 requested accuracy achieved, as determined by rtol'
3959 WRITE(lunit,102) '= 2 reasonable accuracy achieved, given eps'
3960 WRITE(lunit,102) '= 3 x has converged to an eigenvector'
3961 WRITE(lunit,102) '= 4 matrix ill-conditioned (Acond has exceeded 0.1/eps)'
3962 WRITE(lunit,102) '= 5 the iteration limit was reached'
3963 WRITE(lunit,102) '= 6 Matrix x vector does not define a symmetric matrix'
3964 WRITE(lunit,102) '= 7 Preconditioner does not define a symmetric matrix'
3965 ELSEIF (metsol == 5) THEN
3966 WRITE(lunit,101) 'iit', &
3967 'number of internal iterations in MINRES-QLP algorithm'
3968 WRITE(lunit,101) 'st', 'stop code of MINRES-QLP algorithm'
3969 WRITE(lunit,102) '= 1: beta_{k+1} < eps, iteration k is the final Lanczos step.'
3970 WRITE(lunit,102) '= 2: beta2 = 0. If M = I, b and x are eigenvectors of A.'
3971 WRITE(lunit,102) '= 3: beta1 = 0. The exact solution is x = 0.'
3972 WRITE(lunit,102) '= 4: A solution to (poss. singular) Ax = b found, given rtol.'
3973 WRITE(lunit,102) '= 5: A solution to (poss. singular) Ax = b found, given eps.'
3974 WRITE(lunit,102) '= 6: Pseudoinverse solution for singular LS problem, given rtol.'
3975 WRITE(lunit,102) '= 7: Pseudoinverse solution for singular LS problem, given eps.'
3976 WRITE(lunit,102) '= 8: The iteration limit was reached.'
3977 WRITE(lunit,102) '= 9: The operator defined by Aprod appears to be unsymmetric.'
3978 WRITE(lunit,102) '=10: The operator defined by Msolve appears to be unsymmetric.'
3979 WRITE(lunit,102) '=11: The operator defined by Msolve appears to be indefinite.'
3980 WRITE(lunit,102) '=12: xnorm has exceeded maxxnorm or will exceed it next iteration.'
3981 WRITE(lunit,102) '=13: Acond has exceeded Acondlim or 0.1/eps.'
3982 WRITE(lunit,102) '=14: Least-squares problem but no converged solution yet.'
3983 WRITE(lunit,102) '=15: A null vector obtained, given rtol.'
3984 ENDIF
3985 WRITE(lunit,101) 'ls', 'line search info'
3986 WRITE(lunit,102) '< 0 recalculate function'
3987 WRITE(lunit,102) '= 0: N or STP lt 0 or step not descending'
3988 WRITE(lunit,102) '= 1: Linesearch convergence conditions reached'
3989 WRITE(lunit,102) '= 2: interval of uncertainty at lower limit'
3990 WRITE(lunit,102) '= 3: max nr of line search calls reached'
3991 WRITE(lunit,102) '= 4: step at the lower bound'
3992 WRITE(lunit,102) '= 5: step at the upper bound'
3993 WRITE(lunit,102) '= 6: rounding error limitation'
3994 WRITE(lunit,101) 'step', &
3995 'the factor for the Newton step during the line search. Usually'
3996 WRITE(lunit,102) &
3997 'a value of 1 gives a sufficient reduction of the LF. Oherwise'
3998 WRITE(lunit,102) 'other step values are tried.'
3999 WRITE(lunit,101) 'cutf', &
4000 'cut factor. Local fits are rejected, if their chi^2 value'
4001 WRITE(lunit,102) &
4002 'is larger than the 3-sigma chi^2 value times the cut factor.'
4003 WRITE(lunit,102) 'A cut factor of 1 is used finally, but initially a larger'
4004 WRITE(lunit,102) 'factor may be used. A value of 0.0 means no cut.'
4005 WRITE(lunit,101) 'rejects', 'total number of rejected local fits.'
4006 WRITE(lunit,101) 'hmmsec', 'the time in hours (h), minutes (mm) and seconds.'
4007 WRITE(lunit,101) 'FMS', 'calculation of Function value, Matrix, Solution.'
4008 WRITE(lunit,*) ' '
4009
4010101 FORMAT(a9,' = ',a)
4011102 FORMAT(13x,a)
4012END SUBROUTINE explfc
4013
4021
4022SUBROUTINE mupdat(i,j,add) !
4023 USE mpmod
4024
4025 IMPLICIT NONE
4026
4027 INTEGER(mpi), INTENT(IN) :: i
4028 INTEGER(mpi), INTENT(IN) :: j
4029 REAL(mpd), INTENT(IN) :: add
4030
4031 INTEGER(mpl):: ijadd
4032 INTEGER(mpl):: ijcsr3
4033 INTEGER(mpl):: ia
4034 INTEGER(mpl):: ja
4035 INTEGER(mpl):: ij
4036 ! ...
4037 IF(i <= 0.OR.j <= 0.OR. add == 0.0_mpd) RETURN
4038 ia=max(i,j) ! larger
4039 ja=min(i,j) ! smaller
4040 ij=0
4041 IF(matsto == 3) THEN
4042 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
4043 ij=ijcsr3(i,j) ! inline code requires same time
4044 IF (ij > 0) globalmatd(ij)=globalmatd(ij)+add
4045 RETURN
4046 ELSE ! sparse symmetric matrix (BSR3)
4047 ! block index
4048 ij=ijcsr3((i-1)/matbsz+1,(j-1)/matbsz+1)
4049 IF (ij > 0) THEN
4050 ! index of first element in block
4051 ij=(ij-1)*matbsz*matbsz+1
4052 ! adjust index for position in block
4053 ij=ij+mod(int(ia-1,mpi),matbsz)*matbsz+mod(int(ja-1,mpi),matbsz)
4054 globalmatd(ij)=globalmatd(ij)+add
4055 ENDIF
4056 RETURN
4057 END IF
4058 ELSE IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4059 ij=ijadd(i,j) ! inline code requires same time
4060 IF (ij == 0) RETURN ! pair is suppressed
4061 IF (ij > 0) THEN
4062 globalmatd(ij)=globalmatd(ij)+add
4063 ELSE
4064 globalmatf(-ij)=globalmatf(-ij)+real(add,mps)
4065 END IF
4066 ELSE ! full or unpacked (block diagonal) symmetric matrix
4067 ! global (ia,ib) to local (row,col) in block
4068 ij=globalrowoffsets(ia)+ja
4069 globalmatd(ij)=globalmatd(ij)+add
4070 END IF
4071 ! MINRES preconditioner
4072 IF(metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) THEN
4073 ij=0 ! no update
4074 IF(ia <= nvgb) THEN ! variable global parameter
4075 IF(mbandw > 0) THEN ! band matrix for Cholesky decomposition
4076 ij=indprecond(ia)-ia+ja
4077 IF(ia > 1.AND.ij <= indprecond(ia-1)) ij=0
4078 ELSE ! default preconditioner (diagonal)
4079 IF(ja == ia) ij=ia
4080 END IF
4081 ELSE ! Lagrange multiplier
4082 ij=offprecond(ia-nvgb)+ja
4083 END IF
4084 ! bad index?
4085 IF(ij < 0.OR.ij > size(matprecond)) THEN
4086 CALL peend(23,'Aborted, bad matrix index')
4087 stop 'mupdat: bad index'
4088 END IF
4089 ! update?
4090 IF(ij /= 0) matprecond(ij)=matprecond(ij)+add
4091 END IF
4092END SUBROUTINE mupdat
4093
4094
4106
4107SUBROUTINE mgupdt(i,j1,j2,il,jl,n,sub)
4108 USE mpmod
4109
4110 IMPLICIT NONE
4111
4112 INTEGER(mpi), INTENT(IN) :: i
4113 INTEGER(mpi), INTENT(IN) :: j1
4114 INTEGER(mpi), INTENT(IN) :: j2
4115 INTEGER(mpi), INTENT(IN) :: il
4116 INTEGER(mpi), INTENT(IN) :: jl
4117 INTEGER(mpi), INTENT(IN) :: n
4118 REAL(mpd), INTENT(IN) :: sub((n*n+n)/2)
4119
4120 INTEGER(mpl):: ij
4121 INTEGER(mpl):: ioff
4122 INTEGER(mpi):: ia
4123 INTEGER(mpi):: ia1
4124 INTEGER(mpi):: ib
4125 INTEGER(mpi):: iblast
4126 INTEGER(mpi):: iblock
4127 INTEGER(mpi):: ijl
4128 INTEGER(mpi):: iprc
4129 INTEGER(mpi):: ir
4130 INTEGER(mpi):: ja
4131 INTEGER(mpi):: jb
4132 INTEGER(mpi):: jblast
4133 INTEGER(mpi):: jblock
4134 INTEGER(mpi):: jc
4135 INTEGER(mpi):: jc1
4136 INTEGER(mpi):: jpg
4137 INTEGER(mpi):: k
4138 INTEGER(mpi):: lr
4139 INTEGER(mpi):: nc
4140
4141 INTEGER(mpl) ijcsr3
4142 ! ...
4143 IF(i <= 0.OR.j1 <= 0.OR.j2 > i) RETURN
4144
4145 IF(matsto == 3) THEN ! sparse symmetric matrix (CSR3, upper triangle)
4146 ja=globalallindexgroups(i) ! first (global) column
4147 jb=globalallindexgroups(i+1)-1 ! last (global) column
4148 ia1=globalallindexgroups(j1) ! first (global) row
4149 ! loop over groups (now in same column)
4150 DO jpg=j1,j2
4151 ia=globalallindexgroups(jpg) ! first (global) row in group
4152 ib=globalallindexgroups(jpg+1)-1 ! last (global) row in group
4153 IF (matbsz < 2) THEN
4154 ! CSR3
4155 ij=ijcsr3(ia,ja)
4156 IF (ij == 0) THEN
4157 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc, matsto
4158 stop
4159 END IF
4160 ioff=ij-ja ! offset
4161 DO ir=ia,ib
4162 jc1=max(ir,ja)
4163 k=il+jc1-ja
4164 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4165 DO jc=jc1,jb
4166 globalmatd(ioff+jc)=globalmatd(ioff+jc)-sub(ijl)
4167 ijl=ijl+k
4168 k=k+1
4169 END DO
4170 ioff=ioff+csr3rowoffsets(ir+1)-csr3rowoffsets(ir)-1
4171 END DO
4172 ELSE
4173 ! BSR3
4174 iblast=-1
4175 jblast=-1
4176 ioff=0
4177 DO ir=ia,ib
4178 iblock=(ir-1)/matbsz+1
4179 jc1=max(ir,ja)
4180 k=il+jc1-ja
4181 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4182 DO jc=jc1,jb
4183 jblock=(jc-1)/matbsz+1
4184 ! index of first element in (new) block
4185 IF (jblock /= jblast.OR.iblock /= iblast) THEN
4186 ioff=(ijcsr3(iblock,jblock)-1)*matbsz*matbsz+1
4187 iblast=iblock
4188 jblast=jblock
4189 END IF
4190 ! adjust index for position in block
4191 ij=ioff+mod(int(ir-1,mpi),matbsz)+mod(int(jc-1,mpi),matbsz)*matbsz
4192 globalmatd(ij)=globalmatd(ij)-sub(ijl)
4193 ijl=ijl+k
4194 k=k+1
4195 END DO
4196 END DO
4197 END IF
4198 END DO
4199 RETURN
4200 END IF
4201
4202 ! lower triangle
4203 ia=globalallindexgroups(i) ! first (global) row
4204 ib=globalallindexgroups(i+1)-1 ! last (global) row
4205 ja=globalallindexgroups(j1) ! first (global) column
4206 jb=globalallindexgroups(j2+1)-1 ! last (global) column
4207
4208 IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4209 CALL ijpgrp(i,j1,ij,lr,iprc) ! index of first element of group 'j1'
4210 IF (ij == 0) THEN
4211 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc,matsto
4212 stop
4213 END IF
4214 k=il
4215 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4216 DO ir=ia,ib
4217 nc=min(ir,jb)-ja ! number of columns -1
4218 IF (jb >= ir) THEN ! diagonal element
4219 globalmatd(ir)=globalmatd(ir)-sub(ijl+jl+nc)
4220 nc=nc-1
4221 END IF
4222 ! off-diagonal elements
4223 IF (iprc == 1) THEN
4224 globalmatd(ij:ij+nc)=globalmatd(ij:ij+nc)-sub(ijl+jl:ijl+jl+nc)
4225 ELSE
4226 globalmatf(ij:ij+nc)=globalmatf(ij:ij+nc)-real(sub(ijl+jl:ijl+jl+nc),mps)
4227 END IF
4228 ij=ij+lr
4229 ijl=ijl+k
4230 k=k+1
4231 END DO
4232 ELSE ! full or unpacked (block diagonal) symmetric matrix
4233 k=il
4234 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4235 DO ir=ia,ib
4236 ! global (ir,0) to local (row,col) in block
4237 ij=globalrowoffsets(ir)
4238 nc=min(ir,jb)-ja ! number of columns -1
4239 globalmatd(ij+ja:ij+ja+nc)=globalmatd(ij+ja:ij+ja+nc)-sub(ijl+jl:ijl+jl+nc)
4240 ijl=ijl+k
4241 k=k+1
4242 END DO
4243 END IF
4244
4245END SUBROUTINE mgupdt
4246
4247
4274
4275SUBROUTINE loopbf(nrej,numfil,naccf,chi2f,ndff)
4276 USE mpmod
4277
4278 IMPLICIT NONE
4279 REAL(mpd) :: cauchy
4280 REAL(mps) :: chichi
4281 REAL(mps) :: chlimt
4282 REAL(mps) :: chndf
4283 REAL(mpd) :: chuber
4284 REAL(mpd) :: down
4285 REAL(mpd) :: pull
4286 REAL(mpd) :: r1
4287 REAL(mpd) :: r2
4288 REAL(mps) :: rec
4289 REAL(mpd) :: rerr
4290 REAL(mpd) :: resid
4291 REAL(mps) :: resing
4292 REAL(mpd) :: resmax
4293 REAL(mpd) :: rmeas
4294 REAL(mpd) :: rmloc
4295 REAL(mpd) :: suwt
4296 REAL(mps) :: used
4297 REAL(mpd) :: wght
4298 REAL(mps) :: chindl
4299 INTEGER(mpi) :: i
4300 INTEGER(mpi) :: ia
4301 INTEGER(mpi) :: ib
4302 INTEGER(mpi) :: ibuf
4303 INTEGER(mpi) :: ichunk
4304 INTEGER(mpl) :: icmn
4305 INTEGER(mpl) :: icost
4306 INTEGER(mpi) :: id
4307 INTEGER(mpi) :: idiag
4308 INTEGER(mpi) :: ieq
4309 INTEGER(mpi) :: iext
4310 INTEGER(mpi) :: ij
4311 INTEGER(mpi) :: ije
4312 INTEGER(mpi) :: ijn
4313 INTEGER(mpi) :: ik
4314 INTEGER(mpi) :: ike
4315 INTEGER(mpi) :: il
4316 INTEGER(mpi) :: im
4317 INTEGER(mpi) :: imeas
4318 INTEGER(mpi) :: in
4319 INTEGER(mpi) :: inv
4320 INTEGER(mpi) :: ioffb
4321 INTEGER(mpi) :: ioffc
4322 INTEGER(mpi) :: ioffd
4323 INTEGER(mpi) :: ioffe
4324 INTEGER(mpi) :: ioffi
4325 INTEGER(mpi) :: ioffq
4326 INTEGER(mpi) :: iprc
4327 INTEGER(mpi) :: iprcnx
4328 INTEGER(mpi) :: iprdbg
4329 INTEGER(mpi) :: iproc
4330 INTEGER(mpi) :: irbin
4331 INTEGER(mpi) :: isize
4332 INTEGER(mpi) :: ist
4333 INTEGER(mpi) :: iter
4334 INTEGER(mpi) :: itgbi
4335 INTEGER(mpi) :: ivgbj
4336 INTEGER(mpi) :: ivgbk
4337 INTEGER(mpi) :: ivpgrp
4338 INTEGER(mpi) :: j
4339 INTEGER(mpi) :: j1
4340 INTEGER(mpi) :: ja
4341 INTEGER(mpi) :: jb
4342 INTEGER(mpi) :: jk
4343 INTEGER(mpi) :: jl
4344 INTEGER(mpi) :: jl1
4345 INTEGER(mpi) :: jn
4346 INTEGER(mpi) :: jnx
4347 INTEGER(mpi) :: joffd
4348 INTEGER(mpi) :: joffi
4349 INTEGER(mpi) :: jproc
4350 INTEGER(mpi) :: jrc
4351 INTEGER(mpi) :: jsp
4352 INTEGER(mpi) :: k
4353 INTEGER(mpi) :: kbdr
4354 INTEGER(mpi) :: kbdrx
4355 INTEGER(mpi) :: kbnd
4356 INTEGER(mpi) :: kfl
4357 INTEGER(mpi) :: kx
4358 INTEGER(mpi) :: lvpgrp
4359 INTEGER(mpi) :: mbdr
4360 INTEGER(mpi) :: mbnd
4361 INTEGER(mpi) :: mside
4362 INTEGER(mpi) :: nalc
4363 INTEGER(mpi) :: nalg
4364 INTEGER(mpi) :: nan
4365 INTEGER(mpi) :: nb
4366 INTEGER(mpi) :: ndf
4367 INTEGER(mpi) :: ndown
4368 INTEGER(mpi) :: neq
4369 INTEGER(mpi) :: nfred
4370 INTEGER(mpi) :: nfrei
4371 INTEGER(mpi) :: ngg
4372 INTEGER(mpi) :: nprdbg
4373 INTEGER(mpi) :: nrank
4374 INTEGER(mpl) :: nrc
4375 INTEGER(mpi) :: nst
4376 INTEGER(mpi) :: nter
4377 INTEGER(mpi) :: nweig
4378 INTEGER(mpi) :: ngrp
4379 INTEGER(mpi) :: npar
4380
4381 INTEGER(mpi), INTENT(IN OUT) :: nrej(0:3)
4382 INTEGER(mpi), INTENT(IN) :: numfil
4383 INTEGER(mpi), INTENT(IN OUT) :: naccf(numfil)
4384 REAL(mps), INTENT(IN OUT) :: chi2f(numfil)
4385 INTEGER(mpi), INTENT(IN OUT) :: ndff(numfil)
4386
4387 REAL(mpd):: dchi2
4388 REAL(mpd)::dvar
4389 REAL(mpd):: dw1
4390 REAL(mpd)::dw2
4391 REAL(mpd)::summ
4392 INTEGER(mpi) :: ijprec
4393
4394 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
4395
4396 LOGICAL:: lprnt
4397 LOGICAL::lhist
4398
4399 CHARACTER (LEN=3):: chast
4400 DATA chuber/1.345_mpd/ ! constant for Huber down-weighting
4401 DATA cauchy/2.3849_mpd/ ! constant for Cauchy down-weighting
4402 SAVE chuber,cauchy
4403 ! ...
4404
4405 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
4406 ! reset header, 3 words per thread:
4407 ! number of entries, offset to data, indices
4408 writebufferinfo=0
4409 writebufferdata=0.
4410 nprdbg=0
4411 iprdbg=-1
4412
4413 ! parallelize record loop
4414 ! private copy of NREJ,.. for each thread, combined at end, init with 0.
4415 !$OMP PARALLEL DO &
4416 !$OMP DEFAULT(PRIVATE) &
4417 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI, &
4418 !$OMP readBufferDataD,writeBufferHeader,writeBufferInfo, &
4419 !$OMP writeBufferData,writeBufferIndices,writeBufferUpdates,globalVector,globalCounter, &
4420 !$OMP globalParameter,globalParLabelIndex,globalIndexUsage,backIndexUsage, &
4421 !$OMP measBins,numMeas,measIndex,measRes,measHists,globalAllParToGroup,globalAllIndexGroups, &
4422 !$OMP localCorrections,localEquations,ifd, &
4423 !$OMP NAGB,NVGB,NAGBN,ICALCM,ICHUNK,NLOOPN,NRECER,NPRDBG,IPRDBG, &
4424 !$OMP NEWITE,CHICUT,LHUBER,CHUBER,ITERAT,NRECPR,MTHRD,NSPC,NAEQN, &
4425 !$OMP DWCUT,CHHUGE,NRECP2,CAUCHY,LFITNP,LFITBB,IMONIT,IMONMD,MONPG1,LUNLOG) &
4426 !$OMP REDUCTION(+:NREJ,NBNDR,NACCF,CHI2F,NDFF) &
4427 !$OMP REDUCTION(MAX:NBNDX,NBDRX) &
4428 !$OMP REDUCTION(MIN:NREC3) &
4429 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
4430 DO ibuf=1,numreadbuffer ! buffer for current record
4431 jrc=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
4432 kfl=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
4433 nrc=ifd(kfl)+jrc ! global record number
4434 dw1=real(readbufferdatad(readbufferpointer(ibuf)-1),mpd) ! weight
4435 dw2=sqrt(dw1)
4436
4437 iproc=0
4438 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
4439 ioffb=nagb*iproc ! offset 'f'.
4440 ioffc=nagbn*iproc ! offset 'c'.
4441 ioffe=nvgb*iproc ! offset 'e'
4442 ioffd=writebufferheader(-1)*iproc+writebufferinfo(2,iproc+1) ! offset data
4443 ioffi=writebufferheader(1)*iproc+writebufferinfo(3,iproc+1)+3 ! offset indices
4444 ioffq=naeqn*iproc ! offset equations (measurements)
4445 ! ----- reset ------------------------------------------------------
4446 lprnt=.false.
4447 lhist=(iproc == 0)
4448 rec=real(nrc,mps) ! floating point value
4449 IF(nloopn == 1.AND.mod(nrc,100000_mpl) == 0) THEN
4450 WRITE(*,*) 'Record',nrc,' ... still reading'
4451 IF(monpg1>0) WRITE(lunlog,*) 'Record',nrc,' ... still reading'
4452 END IF
4453
4454 ! printout/debug only for one thread at a time
4455
4456
4457 ! flag for record printout -----------------------------------------
4458
4459 lprnt=.false.
4460 IF(newite.AND.(iterat == 1.OR.iterat == 3)) THEN
4461 IF(nrc == nrecpr) lprnt=.true.
4462 IF(nrc == nrecp2) lprnt=.true.
4463 IF(nrc == nrecer) lprnt=.true.
4464 END IF
4465 IF (lprnt)THEN
4466 !$OMP ATOMIC
4467 nprdbg=nprdbg+1 ! number of threads with debug
4468 IF (nprdbg == 1) iprdbg=iproc ! first thread with debug
4469 IF (iproc /= iprdbg) lprnt=.false.
4470 ! print *, ' LPRNT ', NRC, NPRDBG, IPRDBG, IPROC, LPRNT
4471 END IF
4472 IF(lprnt) THEN
4473 WRITE(1,*) ' '
4474 WRITE(1,*) '------------------ Loop',nloopn, &
4475 ': Printout for record',nrc,iproc
4476 WRITE(1,*) ' '
4477 END IF
4478
4479 ! ----- print data -------------------------------------------------
4480
4481 IF(lprnt) THEN
4482 imeas=0 ! local derivatives
4483 ist=readbufferpointer(ibuf)+1
4484 nst=readbufferdatai(readbufferpointer(ibuf))
4485 DO ! loop over measurements
4486 CALL isjajb(nst,ist,ja,jb,jsp)
4487 IF(ja == 0) EXIT
4488 IF(imeas == 0) WRITE(1,1121)
4489 imeas=imeas+1
4490 WRITE(1,1122) imeas,readbufferdatad(ja),readbufferdatad(jb), &
4491 (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
4492 END DO
44931121 FORMAT(/'Measured value and local derivatives'/ &
4494 ' i measured std_dev index...derivative ...')
44951122 FORMAT(i3,2g12.4,3(i3,g12.4)/(27x,3(i3,g12.4)))
4496
4497 imeas=0 ! global derivatives
4498 ist=readbufferpointer(ibuf)+1
4499 nst=readbufferdatai(readbufferpointer(ibuf))
4500 DO ! loop over measurements
4501 CALL isjajb(nst,ist,ja,jb,jsp)
4502 IF(ja == 0) EXIT
4503 IF(imeas == 0) WRITE(1,1123)
4504 imeas=imeas+1
4505 IF (jb < ist) THEN
4506 IF(ist-jb > 2) THEN
4507 WRITE(1,1124) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4508 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4509 ELSE
4510 WRITE(1,1125) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4511 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4512 END IF
4513 END IF
4514 END DO
45151123 FORMAT(/'Global derivatives'/ &
4516 ' i label gindex vindex derivative ...')
45171124 FORMAT(i3,2(i9,i7,i7,g12.4)/(3x,2(i9,i7,i7,g12.4)))
45181125 FORMAT(i3,2(i9,i7,i7,g12.4))
4519 END IF
4520
4521 ! ----- first loop -------------------------------------------------
4522 ! ------ prepare local fit ------
4523 ! count local and global derivates
4524 ! subtract actual alignment parameters from the measured data
4525
4526 IF(lprnt) THEN
4527 WRITE(1,*) ' '
4528 WRITE(1,*) 'Data corrections using values of global parameters'
4529 WRITE(1,*) '=================================================='
4530 WRITE(1,101)
4531 END IF
4532 nalg=0 ! count number of global derivatives
4533 nalc=0 ! count number of local derivatives
4534 neq=0 ! count number of equations
4535
4536 ist=readbufferpointer(ibuf)+1
4537 nst=readbufferdatai(readbufferpointer(ibuf))
4538 DO ! loop over measurements
4539 CALL isjajb(nst,ist,ja,jb,jsp)
4540 IF(ja == 0) EXIT
4541 rmeas=real(readbufferdatad(ja),mpd) ! data
4542 neq=neq+1 ! count equation
4543 localequations(1,ioffq+neq)=ja
4544 localequations(2,ioffq+neq)=jb
4545 localequations(3,ioffq+neq)=ist
4546 ! subtract global ... from measured value
4547 DO j=1,ist-jb ! global parameter loop
4548 itgbi=readbufferdatai(jb+j) ! global parameter label
4549 rmeas=rmeas-real(readbufferdatad(jb+j),mpd)*globalparameter(itgbi) ! subtract !!! reversed
4550 IF (icalcm == 1) THEN
4551 ij=globalparlabelindex(2,itgbi) ! -> index of variable global parameter
4552 IF(ij > 0) THEN
4553 ijn=backindexusage(ioffe+ij) ! get index of index
4554 IF(ijn == 0) THEN ! not yet included
4555 nalg=nalg+1 ! count
4556 globalindexusage(ioffc+nalg)=ij ! store global index
4557 backindexusage(ioffe+ij)=nalg ! store back index
4558 END IF
4559 END IF
4560 END IF
4561 END DO
4562 IF(lprnt) THEN
4563 IF (jb < ist) WRITE(1,102) neq,readbufferdatad(ja),rmeas,readbufferdatad(jb)
4564 END IF
4565 readbufferdatad(ja)=real(rmeas,mpr8) ! global contribution subtracted
4566 DO j=1,jb-ja-1 ! local parameter loop
4567 ij=readbufferdatai(ja+j)
4568 nalc=max(nalc,ij) ! number of local parameters
4569 END DO
4570 END DO
4571101 FORMAT(' index measvalue corrvalue sigma')
4572102 FORMAT(i6,2x,2g12.4,' +-',g12.4)
4573
4574 IF(nalc <= 0) GO TO 90
4575
4576 ngg=(nalg*nalg+nalg)/2
4577 ngrp=0
4578 IF (icalcm == 1) THEN
4579 localglobalmatrix(:nalg*nalc)=0.0_mpd ! reset global-local matrix
4580 localglobalmap(:nalg*nalc)=0 ! reset global-local map
4581 ! store parameter group indices
4582 CALL sort1k(globalindexusage(ioffc+1),nalg) ! sort global par.
4583 lvpgrp=-1
4584 npar=0
4585 DO k=1,nalg
4586 iext=globalindexusage(ioffc+k)
4587 backindexusage(ioffe+iext)=k ! update back index
4588 ivpgrp=globalallpartogroup(iext) ! group
4589 IF (ivpgrp /= lvpgrp) THEN
4590 ngrp=ngrp+1
4591 writebufferindices(ioffi+ngrp)=ivpgrp ! global par group indices
4592 lvpgrp=ivpgrp
4593 npar=npar+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4594 END IF
4595 END DO
4596 ! check NPAR==NALG
4597 IF (npar /= nalg) THEN
4598 print *, ' mismatch of number of global parameters ', nrc, nalg, npar, ngrp
4599 print *, globalindexusage(ioffc+1:ioffc+nalg)
4600 print *, writebufferindices(ioffi+1:ioffi+ngrp)
4601 j=0
4602 DO k=1,ngrp
4603 ivpgrp=writebufferindices(ioffi+k)
4604 j=j+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4605 IF (globalallpartogroup(globalindexusage(ioffc+j)) /= ivpgrp) &
4606 print *, ' bad group ', k, j, ivpgrp, globalindexusage(ioffc+j)
4607 END DO
4608 CALL peend(35,'Aborted, mismatch of number of global parameters')
4609 stop ' mismatch of number of global parameters '
4610 ENDIF
4611 ! index header
4612 writebufferindices(ioffi-2)=jrc ! record number in file
4613 writebufferindices(ioffi-1)=nalg ! number of global parameters
4614 writebufferindices(ioffi )=ngrp ! number of global par groups
4615 DO k=1,ngg
4616 writebufferupdates(ioffd+k)=0.0_mpd ! reset global-global matrix
4617 END DO
4618 END IF
4619 ! ----- iteration start and check ---------------------------------
4620
4621 nter=1 ! first loop without down-weighting
4622 IF(nloopn /= 1.AND.lhuber /= 0) nter=lhuber
4623 localcorrections(ioffq+1:ioffq+neq) = 0._mpd
4624
4625 ! check matrix for bordered band structure (MBDR+MBND+1 <= NALC)
4626 mbnd=-1
4627 mbdr=nalc
4628 mside=-1 ! side (1: upper/left border, 2: lower/right border)
4629 DO i=1, 2*nalc
4630 ibandh(i)=0
4631 END DO
4632 idiag=1
4633
4634 iter=0
4635 resmax=0.0
4636 DO WHILE(iter < nter) ! outlier suppresssion iteration loop
4637 iter=iter+1
4638 resmax=0.0
4639 IF(lprnt) THEN
4640 WRITE(1,*) ' '
4641 WRITE(1,*) 'Outlier-suppression iteration',iter,' of',nter
4642 WRITE(1,*) '=========================================='
4643 WRITE(1,*) ' '
4644 imeas=0
4645 END IF
4646
4647 ! ----- second loop ------------------------------------------------
4648 ! accumulate normal equations for local fit and determine solution
4649 DO i=1,nalc
4650 blvec(i)=0.0_mpd ! reset vector
4651 END DO
4652 DO i=1,(nalc*nalc+nalc)/2 ! GF: FIXME - not really, local parameter number...
4653 clmat(i)=0.0_mpd ! (p)reset matrix
4654 END DO
4655 ndown=0
4656 nweig=0
4657 DO ieq=1,neq! loop over measurements
4658 ja=localequations(1,ioffq+ieq)
4659 jb=localequations(2,ioffq+ieq)
4660 rmeas=real(readbufferdatad(ja),mpd) ! data
4661 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4662 wght =1.0_mpd/rerr**2 ! weight from error
4663 nweig=nweig+1
4664 resid=rmeas-localcorrections(ioffq+ieq) ! subtract previous fit
4665 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4666 IF(iter <= 3) THEN
4667 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4668 wght=wght*chuber*rerr/abs(resid)
4669 ndown=ndown+1
4670 END IF
4671 ELSE ! Cauchy
4672 wght=wght/(1.0+(resid/rerr/cauchy)**2)
4673 END IF
4674 END IF
4675
4676 IF(lprnt.AND.iter /= 1.AND.nter /= 1) THEN
4677 chast=' '
4678 IF(abs(resid) > chuber*rerr) chast='* '
4679 IF(abs(resid) > 3.0*rerr) chast='** '
4680 IF(abs(resid) > 6.0*rerr) chast='***'
4681 IF(imeas == 0) WRITE(1,*) 'Second loop: accumulate'
4682 IF(imeas == 0) WRITE(1,103)
4683 imeas=imeas+1
4684 down=1.0/sqrt(wght)
4685 r1=resid/rerr
4686 r2=resid/down
4687 WRITE(1,104) imeas,rmeas,resid,rerr,r1,chast,r2
4688 END IF
4689103 FORMAT(' index corrvalue residuum sigma', &
4690 ' nresid cnresid')
4691104 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4692
4693 DO j=1,jb-ja-1 ! normal equations, local parameter loop
4694 ij=readbufferdatai(ja+j) ! local parameter index J
4695 blvec(ij)=blvec(ij)+wght*rmeas*real(readbufferdatad(ja+j),mpd)
4696 DO k=1,j
4697 ik=readbufferdatai(ja+k) ! local parameter index K
4698 jk=(ij*ij-ij)/2+ik ! index in symmetric matrix
4699 clmat(jk)=clmat(jk) & ! force double precision
4700 +wght*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)
4701 ! check for band matrix substructure
4702 IF (iter == 1) THEN
4703 id=iabs(ij-ik)+1
4704 im=min(ij,ik) ! upper/left border
4705 ibandh(id)=max(ibandh(id),im)
4706 im=min(nalc+1-ij,nalc+1-ik) ! lower/rght border (mirrored)
4707 ibandh(nalc+id)=max(ibandh(nalc+id),im)
4708 END IF
4709 END DO
4710 END DO
4711 END DO
4712 ! for non trivial fits check for bordered band matrix structure
4713 IF (iter == 1.AND.nalc > 5.AND.lfitbb > 0) THEN
4714 kx=-1
4715 kbdrx=0
4716 icmn=int(nalc,mpl)**3 ! cost (*6) should improve by at least factor 2
4717 ! upper/left border ?
4718 kbdr=0
4719 DO k=nalc,2,-1
4720 kbnd=k-2
4721 kbdr=max(kbdr,ibandh(k))
4722 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4723 IF (icost < icmn) THEN
4724 icmn=icost
4725 kx=k
4726 kbdrx=kbdr
4727 mside=1
4728 END IF
4729 END DO
4730 IF (kx < 0) THEN
4731 ! lower/right border instead?
4732 kbdr=0
4733 DO k=nalc,2,-1
4734 kbnd=k-2
4735 kbdr=max(kbdr,ibandh(k+nalc))
4736 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4737 IF (icost < icmn) THEN
4738 icmn=icost
4739 kx=k
4740 kbdrx=kbdr
4741 mside=2
4742 END IF
4743 END DO
4744 END IF
4745 IF (kx > 0) THEN
4746 mbnd=kx-2
4747 mbdr=kbdrx
4748 END IF
4749 END IF
4750
4751 IF (mbnd >= 0) THEN
4752 ! fast solution for border banded matrix (inverse for ICALCM>0)
4753 IF (nloopn == 1) THEN
4754 nbndr(mside)=nbndr(mside)+1
4755 nbdrx=max(nbdrx,mbdr)
4756 nbndx=max(nbndx,mbnd)
4757 END IF
4758
4759 inv=0
4760 IF (nloopn <= lfitnp.AND.iter == 1) inv=1 ! band part of inverse (for pulls)
4761 IF (icalcm == 1.OR.lprnt) inv=2 ! complete inverse
4762 IF (mside == 1) THEN
4763 CALL sqmibb(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4764 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag)
4765 ELSE
4766 CALL sqmibb2(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4767 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag)
4768 ENDIF
4769 ELSE
4770 ! full inversion and solution
4771 inv=2
4772 CALL sqminv(clmat,blvec,nalc,nrank,scdiag,scflag)
4773 END IF
4774 ! check for NaNs
4775 nan=0
4776 DO k=1, nalc
4777 IF ((.NOT.(blvec(k) <= 0.0_mpd)).AND. (.NOT.(blvec(k) > 0.0_mpd))) nan=nan+1
4778 END DO
4779
4780 IF(lprnt) THEN
4781 WRITE(1,*) ' '
4782 WRITE(1,*) 'Parameter determination:',nalc,' parameters,', ' rank=',nrank
4783 WRITE(1,*) '-----------------------'
4784 IF(ndown /= 0) WRITE(1,*) ' ',ndown,' data down-weighted'
4785 WRITE(1,*) ' '
4786 END IF
4787
4788 ! ----- third loop -------------------------------------------------
4789 ! calculate single residuals remaining after local fit and chi^2
4790
4791 summ=0.0_mpd
4792 suwt=0.0
4793 imeas=0
4794 DO ieq=1,neq! loop over measurements
4795 ja=localequations(1,ioffq+ieq)
4796 jb=localequations(2,ioffq+ieq)
4797 ist=localequations(3,ioffq+ieq)
4798 rmeas=real(readbufferdatad(ja),mpd) ! data (global contrib. subtracted)
4799 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4800 wght =1.0_mpd/rerr**2 ! weight from error
4801 rmloc=0.0 ! local fit result reset
4802 DO j=1,jb-ja-1 ! local parameter loop
4803 ij=readbufferdatai(ja+j)
4804 rmloc=rmloc+real(readbufferdatad(ja+j),mpd)*blvec(ij) ! local fit result
4805 END DO
4806 localcorrections(ioffq+ieq)=rmloc ! save local fit result
4807 rmeas=rmeas-rmloc ! reduced to residual
4808
4809 ! calculate pulls? (needs covariance matrix)
4810 IF(iter == 1.AND.inv > 0.AND.nloopn <= lfitnp) THEN
4811 dvar=0.0_mpd
4812 DO j=1,jb-ja-1
4813 ij=readbufferdatai(ja+j)
4814 jk=(ij*ij-ij)/2 ! index in symmetric matrix, row offset
4815 ! off diagonal (symmetric)
4816 DO k=1,j-1
4817 ik=readbufferdatai(ja+k)
4818 dvar=dvar+clmat(jk+ik)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)*2.0_mpd
4819 END DO
4820 ! diagonal
4821 dvar=dvar+clmat(jk+ij)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+j),mpd)
4822 END DO
4823 ! some variance left to define a pull?
4824 IF (0.999999_mpd/wght > dvar) THEN
4825 pull=rmeas/sqrt(1.0_mpd/wght-dvar)
4826 IF (lhist) THEN
4827 IF (jb < ist) THEN
4828 CALL hmpent(13,real(pull,mps)) ! histogram pull
4829 CALL gmpms(5,rec,real(pull,mps))
4830 ELSE
4831 CALL hmpent(14,real(pull,mps)) ! histogram pull
4832 END IF
4833 END IF
4834 ! monitoring
4835 IF (imonit /= 0) THEN
4836 IF (jb < ist) THEN
4837 ij=readbufferdatai(jb+1) ! group by first global label
4838 if (imonmd == 0) THEN
4839 irbin=min(measbins,max(1,int(pull*rerr/measres(ij)/measbinsize+0.5*real(measbins,mpd))))
4840 ELSE
4841 irbin=min(measbins,max(1,int(pull/measbinsize+0.5*real(measbins,mpd))))
4842 ENDIF
4843 irbin=irbin+measbins*(measindex(ij)-1+nummeas*iproc)
4844 meashists(irbin)=meashists(irbin)+1
4845 ENDIF
4846 ENDIF
4847 END IF
4848 END IF
4849
4850 IF(iter == 1.AND.jb < ist.AND.lhist) &
4851 CALL gmpms(4,rec,real(rmeas/rerr,mps)) ! residual (with global deriv.)
4852
4853 dchi2=wght*rmeas*rmeas
4854 ! DCHIT=DCHI2
4855 resid=rmeas
4856 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4857 IF(iter <= 3) THEN
4858 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4859 wght=wght*chuber*rerr/abs(resid)
4860 dchi2=2.0*chuber*(abs(resid)/rerr-0.5*chuber)
4861 END IF
4862 ELSE
4863 wght=wght/(1.0_mpd+(resid/rerr/cauchy)**2)
4864 dchi2=log(1.0_mpd+(resid/rerr/cauchy)**2)*cauchy**2
4865 END IF
4866 END IF
4867
4868 down=1.0/sqrt(wght)
4869
4870 ! SUWT=SUWT+DCHI2/DCHIT
4871 suwt=suwt+rerr/down
4872 IF(lprnt) THEN
4873 chast=' '
4874 IF(abs(resid) > chuber*rerr) chast='* '
4875 IF(abs(resid) > 3.0*rerr) chast='** '
4876 IF(abs(resid) > 6.0*rerr) chast='***'
4877 IF(imeas == 0) WRITE(1,*) 'Third loop: single residuals'
4878 IF(imeas == 0) WRITE(1,105)
4879 imeas=imeas+1
4880 r1=resid/rerr
4881 r2=resid/down
4882 IF(resid < 0.0) r1=-r1
4883 IF(resid < 0.0) r2=-r2
4884 WRITE(1,106) imeas,readbufferdatad(ja),rmeas,rerr,r1,chast,r2
4885 END IF
4886105 FORMAT(' index corrvalue residuum sigma', &
4887 ' nresid cnresid')
4888106 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4889
4890 IF(iter == nter) THEN
4891 readbufferdatad(ja)=real(rmeas,mpr8) ! store remaining residual
4892 resmax=max(resmax,abs(rmeas)/rerr)
4893 END IF
4894
4895 IF(iter == 1.AND.lhist) THEN
4896 IF (jb < ist) THEN
4897 CALL hmpent( 3,real(rmeas/rerr,mps)) ! histogram norm residual
4898 ELSE
4899 CALL hmpent(12,real(rmeas/rerr,mps)) ! histogram norm residual
4900 END IF
4901 END IF
4902 summ=summ+dchi2 ! accumulate chi-square sum
4903 END DO
4904
4905 ndf=neq-nrank
4906 resing=(real(nweig,mps)-real(suwt,mps))/real(nweig,mps)
4907 IF (lhist) THEN
4908 IF(iter == 1) CALL hmpent( 5,real(ndf,mps)) ! histogram Ndf
4909 IF(iter == 1) CALL hmpent(11,real(nalc,mps)) ! histogram Nlocal
4910 IF(nloopn == 2.AND.iter == nter) CALL hmpent(6,resing)
4911 END IF
4912 IF(lprnt) THEN
4913 WRITE(1,*) ' '
4914 WRITE(1,*) 'Chi^2=',summ,' at',ndf,' degrees of freedom: ', &
4915 '3-sigma limit is',chindl(3,ndf)*real(ndf,mps)
4916 WRITE(1,*) suwt,' is sum of factors, compared to',nweig, &
4917 ' Downweight fraction:',resing
4918 END IF
4919 IF(nrank /= nalc.OR.nan > 0) THEN
4920 nrej(0)=nrej(0)+1 ! count cases
4921 IF (nrec3 == huge(nrec3)) nrec3=nrc
4922 IF(lprnt) THEN
4923 WRITE(1,*) ' rank deficit/NaN ', nalc, nrank, nan
4924 WRITE(1,*) ' ---> rejected!'
4925 END IF
4926 GO TO 90
4927 END IF
4928 IF(ndf <= 0) THEN
4929 nrej(1)=nrej(1)+1 ! count cases
4930 IF(lprnt) THEN
4931 WRITE(1,*) ' ---> rejected!'
4932 END IF
4933 GO TO 90
4934 END IF
4935
4936 chndf=real(summ/real(ndf,mpd),mps)
4937
4938 IF(iter == 1.AND.lhist) CALL hmpent(4,chndf) ! histogram chi^2/Ndf
4939 END DO ! outlier iteration loop
4940
4941 ! ----- reject eventually ------------------------------------------
4942
4943 IF(newite.AND.iterat == 2) THEN ! find record with largest Chi^2/Ndf
4944 IF(nrecp2 < 0.AND.chndf > writebufferdata(2,iproc+1)) THEN
4945 writebufferdata(2,iproc+1)=chndf
4946 writebufferinfo(8,iproc+1)=jrc
4947 writebufferinfo(9,iproc+1)=kfl
4948 END IF
4949 END IF
4950
4951 chichi=chindl(3,ndf)*real(ndf,mps)
4952 ! GF IF(SUMM.GT.50.0*CHICHI) THEN ! huge
4953 ! CHK CHICUT<0: NO cut (1st iteration)
4954 IF(chicut >= 0.0) THEN
4955 IF(summ > chhuge*chichi) THEN ! huge
4956 nrej(2)=nrej(2)+1 ! count cases with huge chi^2
4957 IF(lprnt) THEN
4958 WRITE(1,*) ' ---> rejected!'
4959 END IF
4960 GO TO 90
4961 END IF
4962
4963 IF(chicut > 0.0) THEN
4964 chlimt=chicut*chichi
4965 ! WRITE(*,*) 'chi^2 ',SUMM,CHLIMT,CHICUT,CHINDL(3,NDF),NDF
4966 IF(summ > chlimt) THEN
4967 IF(lprnt) THEN
4968 WRITE(1,*) ' ---> rejected!'
4969 END IF
4970 ! add to FVALUE
4971 dchi2=chlimt ! total contribution limit
4972 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
4973 nrej(3)=nrej(3)+1 ! count cases with large chi^2
4974 GO TO 90
4975 END IF
4976 END IF
4977 END IF
4978
4979 IF(lhuber > 1.AND.dwcut /= 0.0.AND.resing > dwcut) THEN
4980 ! add to FVALUE
4981 dchi2=summ ! total contribution
4982 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
4983 nrej(3)=nrej(3)+1 ! count cases with large chi^2
4984 ! WRITE(*,*) 'Downweight fraction cut ',RESING,DWCUT,SUMM
4985 IF(lprnt) THEN
4986 WRITE(1,*) ' ---> rejected!'
4987 END IF
4988 GO TO 90
4989 END IF
4990
4991 IF(newite.AND.iterat == 2) THEN ! find record with largest residual
4992 IF(nrecpr < 0.AND.resmax > writebufferdata(1,iproc+1)) THEN
4993 writebufferdata(1,iproc+1)=real(resmax,mps)
4994 writebufferinfo(6,iproc+1)=jrc
4995 writebufferinfo(7,iproc+1)=kfl
4996 END IF
4997 END IF
4998 ! 'track quality' per binary file: accepted records
4999 naccf(kfl)=naccf(kfl)+1
5000 ndff(kfl) =ndff(kfl) +ndf
5001 chi2f(kfl)=chi2f(kfl)+chndf
5002
5003 ! ----- fourth loop ------------------------------------------------
5004 ! update of global matrix and vector according to the "Millepede"
5005 ! principle, from the global/local information
5006
5007 summ=0.0_mpd
5008 DO ieq=1,neq! loop over measurements
5009 ja=localequations(1,ioffq+ieq)
5010 jb=localequations(2,ioffq+ieq)
5011 ist=localequations(3,ioffq+ieq)
5012 rmeas=real(readbufferdatad(ja),mpd) ! data residual
5013 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
5014 wght =1.0_mpd/rerr**2 ! weight from measurement error
5015 dchi2=wght*rmeas*rmeas ! least-square contribution
5016
5017 IF(nloopn /= 1.AND.lhuber /= 0) THEN ! check residual
5018 resid=abs(rmeas)
5019 IF(resid > chuber*rerr) THEN
5020 wght=wght*chuber*rerr/resid ! down-weighting
5021 dchi2=2.0*chuber*(resid/rerr-0.5*chuber) ! modified contribution
5022 END IF
5023 END IF
5024 ! sum up
5025 summ=summ+dchi2
5026
5027 ! global-global matrix contribution: add directly to gg-matrix
5028
5029 DO j=1,ist-jb
5030 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5031 IF(ivgbj > 0) THEN
5032 globalvector(ioffb+ivgbj)=globalvector(ioffb+ivgbj) &
5033 +dw1*wght*rmeas*real(readbufferdatad(jb+j),mpd) ! vector !!! reverse
5034 globalcounter(ioffb+ivgbj)=globalcounter(ioffb+ivgbj)+1
5035 IF(icalcm == 1) THEN
5036 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5037 DO k=1,j
5038 ivgbk=globalparlabelindex(2,readbufferdatai(jb+k))
5039 IF(ivgbk > 0) THEN
5040 ike=backindexusage(ioffe+ivgbk) ! get index of index, non-zero
5041 ia=max(ije,ike) ! larger
5042 ib=min(ije,ike) ! smaller
5043 ij=ib+(ia*ia-ia)/2
5044 writebufferupdates(ioffd+ij)=writebufferupdates(ioffd+ij) &
5045 -dw1*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(jb+k),mpd)
5046 END IF
5047 END DO
5048 END IF
5049 END IF
5050 END DO
5051
5052 ! normal equations - rectangular matrix for global/local pars
5053 ! global-local matrix contribution: accumulate rectangular matrix
5054 IF (icalcm /= 1) cycle
5055 DO j=1,ist-jb
5056 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5057 IF(ivgbj > 0) THEN
5058 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5059 DO k=1,jb-ja-1
5060 ik=readbufferdatai(ja+k) ! local index
5061 jk=ik+(ije-1)*nalc ! matrix index
5062 localglobalmatrix(jk)=localglobalmatrix(jk)+ &
5063 dw2*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(ja+k),mpd)
5064 localglobalmap(jk)=localglobalmap(jk)+1
5065 END DO
5066 END IF
5067 END DO
5068 END DO
5069 ! add to total objective function
5070 CALL addsums(iproc+1, summ, ndf, dw1)
5071
5072 ! ----- final matrix update ----------------------------------------
5073 ! update global matrices and vectors
5074 IF(icalcm /= 1) GO TO 90 ! matrix update
5075 ! (inverse local matrix) * (rectang. matrix) -> CORM
5076 ! T
5077 ! resulting symmetrix matrix = G * Gamma^{-1} * G
5078
5079 ! check sparsity of localGlobalMatrix (with par. groups)
5080 isize=nalc+nalg+1 ! row/clolumn offsets
5081 ! check rows
5082 k=0 ! offset
5083 DO i=1, nalg
5084 localglobalstructure(i)=isize
5085 DO j=1, nalc
5086 IF (localglobalmap(k+j) > 0) THEN
5087 localglobalstructure(isize+1)=j ! column
5088 localglobalstructure(isize+2)=k+j ! index
5089 isize=isize+2
5090 ENDIF
5091 END DO
5092 k=k+nalc
5093 END DO
5094 ! <50% non-zero elements?
5095 IF (isize-localglobalstructure(1) < nalc*nalg) THEN
5096 ! check columns (too)
5097 DO j=1, nalc
5098 localglobalstructure(nalg+j)=isize
5099 k=0 ! offset
5100 DO i=1, nalg
5101 IF (localglobalmap(k+j) > 0) THEN
5102 localglobalstructure(isize+1)=i ! row
5103 localglobalstructure(isize+2)=k+j ! index
5104 isize=isize+2
5105 ENDIF
5106 k=k+nalc
5107 END DO
5108 END DO
5109 localglobalstructure(nalg+nalc+1)=isize
5110 CALL dbavats(clmat,localglobalmatrix,localglobalstructure,writebufferupdates(ioffd+1),nalc,nalg,1,scflag)
5111 ELSE
5112 CALL dbavat(clmat,localglobalmatrix,writebufferupdates(ioffd+1),nalc,nalg,1)
5113 END IF
5114 ! (rectang. matrix) * (local param vector) -> CORV
5115 ! resulting vector = G * q (q = local parameter)
5116 ! CALL DBGAX(DQ(IGLMA/2+1),BLVEC,DQ(ICORV/2+1),NALG,NALC) ! not done
5117 ! the vector update is not done, because after local fit it is zero!
5118
5119 ! update cache status
5120 writebufferinfo(1,iproc+1)=writebufferinfo(1,iproc+1)+1
5121 writebufferinfo(2,iproc+1)=writebufferinfo(2,iproc+1)+ngg
5122 writebufferinfo(3,iproc+1)=writebufferinfo(3,iproc+1)+ngrp+3
5123 ! check free space
5124 nfred=writebufferheader(-1)-writebufferinfo(2,iproc+1)-writebufferheader(-2)
5125 nfrei=writebufferheader(1)-writebufferinfo(3,iproc+1)-writebufferheader(2)
5126 IF (nfred < 0.OR.nfrei < 0) THEN ! need to flush
5127 nb=writebufferinfo(1,iproc+1)
5128 joffd=writebufferheader(-1)*iproc ! offset data
5129 joffi=writebufferheader(1)*iproc+3 ! offset indices
5130 used=real(writebufferinfo(2,iproc+1),mps)/real(writebufferheader(-1),mps)
5131 writebufferinfo(4,iproc+1)=writebufferinfo(4,iproc+1) +nint(1000.0*used,mpi)
5132 used=real(writebufferinfo(3,iproc+1),mps)/real(writebufferheader(1),mps)
5133 writebufferinfo(5,iproc+1)=writebufferinfo(5,iproc+1) +nint(1000.0*used,mpi)
5134 !$OMP CRITICAL
5135 writebufferheader(-4)=writebufferheader(-4)+1
5136 writebufferheader(4)=writebufferheader(4)+1
5137
5138 DO ib=1,nb
5139 nalg=writebufferindices(joffi-1)
5140 il=1 ! row in update matrix
5141 DO in=1,writebufferindices(joffi)
5142 i=writebufferindices(joffi+in)
5143 j=writebufferindices(joffi+1) ! 1. group
5144 iprc=ijprec(i,j) ! group pair precision
5145 jl=1 ! col in update matrix
5146 ! start (rows) for continous groups
5147 j1=j
5148 jl1=jl
5149 ! other groups for row
5150 DO jn=2,in
5151 jl=jl+globalallindexgroups(j+1)-globalallindexgroups(j)
5152 jnx=writebufferindices(joffi+jn) ! next group
5153 iprcnx=ijprec(i,jnx) ! group pair precision
5154 ! end of continous groups?
5155 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5156 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5157 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5158 ! restart continous groups
5159 j1=jnx ! new 1. column
5160 jl1=jl
5161 iprc=iprcnx
5162 END IF
5163 j=jnx ! last group
5164 END DO
5165 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5166 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5167 il=il+globalallindexgroups(i+1)-globalallindexgroups(i)
5168 END DO
5169 joffd=joffd+(il*il-il)/2
5170 joffi=joffi+writebufferindices(joffi)+3
5171 END DO
5172 !$OMP END CRITICAL
5173 ! reset counter, pointers
5174 DO k=1,3
5175 writebufferinfo(k,iproc+1)=0
5176 END DO
5177 END IF
5178
517990 IF(lprnt) THEN
5180 WRITE(1,*) ' '
5181 WRITE(1,*) '------------------ End of printout for record',nrc
5182 WRITE(1,*) ' '
5183 END IF
5184
5185 DO i=1,nalg ! reset global index array
5186 iext=globalindexusage(ioffc+i)
5187 backindexusage(ioffe+iext)=0
5188 END DO
5189
5190 END DO
5191 !$OMP END PARALLEL DO
5192
5193 IF (icalcm == 1) THEN
5194 ! flush remaining matrices
5195 DO k=1,mthrd ! update statistics
5196 writebufferheader(-3)=writebufferheader(-3)+1
5197 used=real(writebufferinfo(2,k),mps)/real(writebufferheader(-1),mps)
5198 writebufferinfo(4,k)=writebufferinfo(4,k)+nint(1000.0*used,mpi)
5199 writebufferheader(-5)=writebufferheader(-5)+writebufferinfo(4,k)
5200 writebufferheader(-6)=max(writebufferheader(-6),writebufferinfo(4,k))
5201 writebufferinfo(4,k)=0
5202 writebufferheader(3)=writebufferheader(3)+1
5203 used=real(writebufferinfo(3,k),mps)/real(writebufferheader(1),mps)
5204 writebufferinfo(5,k)=writebufferinfo(5,k)+nint(1000.0*used,mpi)
5205 writebufferheader(5)=writebufferheader(5)+writebufferinfo(5,k)
5206 writebufferheader(6)=max(writebufferheader(6),writebufferinfo(5,k))
5207 writebufferinfo(5,k)=0
5208 END DO
5209
5210 !$OMP PARALLEL &
5211 !$OMP DEFAULT(PRIVATE) &
5212 !$OMP SHARED(writeBufferHeader,writeBufferInfo,writeBufferIndices,writeBufferUpdates,MTHRD) &
5213 !$OMP SHARED(globalAllParToGroup,globalAllIndexGroups,nspc)
5214 iproc=0
5215 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5216 DO jproc=0,mthrd-1
5217 nb=writebufferinfo(1,jproc+1)
5218 ! print *, ' flush end ', JPROC, NRC, NB
5219 joffd=writebufferheader(-1)*jproc ! offset data
5220 joffi=writebufferheader(1)*jproc+3 ! offset indices
5221 DO ib=1,nb
5222 ! print *, ' buf end ', JPROC,IB,writeBufferIndices(JOFFI-2),writeBufferIndices(JOFFI)
5223 nalg=writebufferindices(joffi-1)
5224 il=1 ! row in update matrix
5225 DO in=1,writebufferindices(joffi)
5226 i=writebufferindices(joffi+in)
5227 !$ IF (MOD(I,MTHRD).EQ.IPROC) THEN
5228 j=writebufferindices(joffi+1) ! 1. group
5229 iprc=ijprec(i,j) ! group pair precision
5230 jl=1 ! col in update matrix
5231 ! start (rows) for continous groups
5232 j1=j
5233 jl1=jl
5234 ! other groups for row
5235 DO jn=2,in
5236 jl=jl+globalallindexgroups(j+1)-globalallindexgroups(j)
5237 jnx=writebufferindices(joffi+jn) ! next group
5238 iprcnx=ijprec(i,jnx) ! group pair precision
5239 ! end of continous groups?
5240 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5241 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5242 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5243 ! restart continous groups
5244 j1=jnx ! new 1. column
5245 jl1=jl
5246 iprc=iprcnx
5247 END IF
5248 j=jnx ! last group
5249 END DO
5250 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5251 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5252 !$ END IF
5253 il=il+globalallindexgroups(i+1)-globalallindexgroups(i)
5254 END DO
5255 joffd=joffd+(il*il-il)/2
5256 joffi=joffi+writebufferindices(joffi)+3
5257 END DO
5258 END DO
5259 !$OMP END PARALLEL
5260 END IF
5261
5262 IF(newite.AND.iterat == 2) THEN ! get worst records (for printrecord -1 -1)
5263 IF (nrecpr < 0) THEN
5264 DO k=1,mthrd
5265 IF (writebufferdata(1,k) > value1) THEN
5266 value1=writebufferdata(1,k)
5267 nrec1 =writebufferinfo(6,k)+ifd(writebufferinfo(7,k))
5268 END IF
5269 END DO
5270 END IF
5271 IF (nrecp2 < 0) THEN
5272 DO k=1,mthrd
5273 IF (writebufferdata(2,k) > value2) THEN
5274 value2=writebufferdata(2,k)
5275 nrec2 =writebufferinfo(8,k)+ifd(writebufferinfo(9,k))
5276 END IF
5277 END DO
5278 END IF
5279 END IF
5280
5281END SUBROUTINE loopbf
5282
5283
5284
5285
5286!***********************************************************************
5287
5300SUBROUTINE prtglo
5301 USE mpmod
5302
5303 IMPLICIT NONE
5304 REAL(mps):: dpa
5305 REAL(mps):: err
5306 REAL(mps):: gcor
5307 INTEGER(mpi) :: i
5308 INTEGER(mpi) :: icom
5309 INTEGER(mpl) :: icount
5310 INTEGER(mpi) :: ie
5311 INTEGER(mpi) :: iev
5312 INTEGER(mpi) :: ij
5313 INTEGER(mpi) :: imin
5314 INTEGER(mpi) :: iprlim
5315 INTEGER(mpi) :: isub
5316 INTEGER(mpi) :: itgbi
5317 INTEGER(mpi) :: itgbl
5318 INTEGER(mpi) :: ivgbi
5319 INTEGER(mpi) :: j
5320 INTEGER(mpi) :: label
5321 INTEGER(mpi) :: lup
5322 REAL(mps):: par
5323 LOGICAL :: lowstat
5324
5325 REAL(mpd):: diag
5326 REAL(mpd)::gmati
5327 REAL(mpd)::gcor2
5328 INTEGER(mpi) :: labele(3)
5329 REAL(mps):: compnt(3)
5330 SAVE
5331 ! ...
5332
5333 lup=09
5334 CALL mvopen(lup,'millepede.res')
5335
5336 WRITE(*,*) ' '
5337 WRITE(*,*) ' Result of fit for global parameters'
5338 WRITE(*,*) ' ==================================='
5339 WRITE(*,*) ' '
5340
5341 WRITE(*,101)
5342
5343 WRITE(lup,*) 'Parameter ! first 3 elements per line are', &
5344 ' significant (if used as input)'
5345
5346
5347 iprlim=10
5348 DO itgbi=1,ntgb ! all parameter variables
5349 itgbl=globalparlabelindex(1,itgbi)
5350 ivgbi=globalparlabelindex(2,itgbi)
5351 icom=globalparcomments(itgbi) ! comment
5352 IF (icom > 0) WRITE(lup,113) listcomments(icom)%text
5353 par=real(globalparameter(itgbi),mps) ! initial value
5354 icount=0 ! counts
5355 lowstat = .false.
5356 IF(ivgbi > 0) THEN
5357 icount=globalcounter(ivgbi) ! used in last iteration
5358 lowstat = (icount < mreqena) ! too few accepted entries
5359 dpa=real(globalparameter(itgbi)-globalparstart(itgbi),mps) ! difference
5360 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5361 gmati=globalmatd(globalrowoffsets(ivgbi)+ivgbi)
5362 err=sqrt(abs(real(gmati,mps)))
5363 IF(gmati < 0.0_mpd) err=-err
5364 diag=workspacediag(ivgbi)
5365 gcor=-1.0
5366 IF(gmati*diag > 0.0_mpd) THEN ! global correlation
5367 gcor2=1.0_mpd-1.0_mpd/(gmati*diag)
5368 IF(gcor2 >= 0.0_mpd.AND.gcor2 <= 1.0_mpd) gcor=real(sqrt(gcor2),mps)
5369 END IF
5370 END IF
5371 END IF
5372 IF(ipcntr > 1) icount=globalparlabelcounter(itgbi) ! from binary files
5373 IF(lowstat) icount=-(icount+1) ! flag 'lowstat' with icount < 0
5374 IF(itgbi <= iprlim) THEN
5375 IF(ivgbi <= 0) THEN
5376 WRITE(* ,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5377 ELSE
5378 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5379 IF (igcorr == 0) THEN
5380 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5381 ELSE
5382 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5383 END IF
5384 ELSE
5385 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5386 END IF
5387 END IF
5388 ELSE IF(itgbi == iprlim+1) THEN
5389 WRITE(* ,*) '... (further printout suppressed, but see log file)'
5390 END IF
5391
5392 ! file output
5393 IF(ivgbi <= 0) THEN
5394 IF (ipcntr /= 0) THEN
5395 WRITE(lup,110) itgbl,par,real(globalparpresigma(itgbi),mps),icount
5396 ELSE
5397 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5398 END IF
5399 ELSE
5400 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5401 IF (ipcntr /= 0) THEN
5402 WRITE(lup,112) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,icount
5403 ELSE IF (igcorr /= 0) THEN
5404 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5405 ELSE
5406 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5407 END IF
5408 ELSE
5409 IF (ipcntr /= 0) THEN
5410 WRITE(lup,111) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,icount
5411 ELSE
5412 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5413 END IF
5414 END IF
5415 END IF
5416 END DO
5417 rewind lup
5418 CLOSE(unit=lup)
5419
5420 IF(metsol == 2) THEN ! diagonalisation: write eigenvectors
5421 CALL mvopen(lup,'millepede.eve')
5422 imin=1
5423 DO i=nagb,1,-1
5424 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
5425 imin=i ! index of smallest pos. eigenvalue
5426 EXIT
5427 ENDIF
5428 END DO
5429 iev=0
5430
5431 DO isub=0,min(15,imin-1)
5432 IF(isub < 10) THEN
5433 i=imin-isub
5434 ELSE
5435 i=isub-9
5436 END IF
5437
5438 ! DO I=IMIN,MAX(1,IMIN-9),-1 ! backward loop, up to 10 vectors
5439 WRITE(*,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5440 WRITE(lup,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5441 DO j=1,nagb
5442 ij=j+(i-1)*nagb ! index with eigenvector array
5443 IF(j <= nvgb) THEN
5444 itgbi=globalparvartototal(j)
5445 label=globalparlabelindex(1,itgbi)
5446 ELSE
5447 label=nvgb-j ! label negative for constraints
5448 END IF
5449 iev=iev+1
5450 labele(iev)=label
5451 compnt(iev)=real(workspaceeigenvectors(ij),mps) ! component
5452 IF(iev == 3) THEN
5453 WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5454 iev=0
5455 END IF
5456 END DO
5457 IF(iev /= 0) WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5458 iev=0
5459 WRITE(lup,*) ' '
5460 END DO
5461
5462 END IF
5463
5464101 FORMAT(1x,' label parameter presigma differ', &
5465 ' error'/ 1x,'-----------',4x,4('-------------'))
5466102 FORMAT(i10,2x,4g14.5,f8.3)
5467103 FORMAT(3(i11,f11.7,2x))
5468110 FORMAT(i10,2x,2g14.5,28x,i12)
5469111 FORMAT(i10,2x,3g14.5,14x,i12)
5470112 FORMAT(i10,2x,4g14.5,i12)
5471113 FORMAT('!',a)
5472END SUBROUTINE prtglo ! print final log file
5473
5474!***********************************************************************
5475
5485SUBROUTINE prtstat
5486 USE mpmod
5487 USE mpdalc
5488
5489 IMPLICIT NONE
5490 REAL(mps):: par
5491 REAL(mps):: presig
5492 INTEGER(mpi) :: icom
5493 INTEGER(mpl) :: icount
5494 INTEGER(mpi) :: ifrst
5495 INTEGER(mpi) :: ilast
5496 INTEGER(mpi) :: inext
5497 INTEGER(mpi) :: itgbi
5498 INTEGER(mpi) :: itgbl
5499 INTEGER(mpi) :: itpgrp
5500 INTEGER(mpi) :: ivgbi
5501 INTEGER(mpi) :: lup
5502 INTEGER(mpi) :: icgrp
5503 INTEGER(mpi) :: ipgrp
5504 INTEGER(mpi) :: j
5505 INTEGER(mpi) :: jpgrp
5506 INTEGER(mpi) :: k
5507 INTEGER(mpi) :: label1
5508 INTEGER(mpi) :: label2
5509 INTEGER(mpi) :: ncon
5510 INTEGER(mpi) :: npair
5511 INTEGER(mpi) :: nstep
5512 CHARACTER :: c1
5513
5514 INTEGER(mpl):: length
5515
5516 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
5517
5518 INTERFACE ! needed for assumed-shape dummy arguments
5519 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
5520 USE mpdef
5521 INTEGER(mpi), INTENT(IN) :: ipgrp
5522 INTEGER(mpi), INTENT(OUT) :: npair
5523 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
5524 END SUBROUTINE ggbmap
5525 END INTERFACE
5526
5527 SAVE
5528 ! ...
5529
5530 lup=09
5531 CALL mvopen(lup,'millepede.res')
5532 WRITE(lup,*) '*** Results of checking input only, no solution performed ***'
5533 WRITE(lup,*) '! === global parameters ==='
5534 WRITE(lup,*) '! fixed-1: by pre-sigma, -2: by entries cut, -3: by iterated entries cut'
5535 WRITE(lup,*) '! Label Value Pre-sigma Entries Cons. group Status '
5536 !iprlim=10
5537 DO itgbi=1,ntgb ! all parameter variables
5538 itgbl=globalparlabelindex(1,itgbi)
5539 ivgbi=globalparlabelindex(2,itgbi)
5540 icom=globalparcomments(itgbi) ! comment
5541 IF (icom > 0) WRITE(lup,117) listcomments(icom)%text
5542 c1=' '
5543 IF (globalparlabelindex(3,itgbi) == itgbl) c1='>'
5544 par=real(globalparameter(itgbi),mps) ! initial value
5545 presig=real(globalparpresigma(itgbi),mps) ! initial presigma
5546 icount=globalparlabelcounter(itgbi) ! from binary files
5547 icgrp=globalparcons(itgbi) ! constraints group
5548
5549 IF (ivgbi <= 0) THEN
5550 ! not used
5551 IF (ivgbi == -4) THEN
5552 WRITE(lup,116) c1,itgbl,par,presig,icount,icgrp
5553 ELSE
5554 WRITE(lup,110) c1,itgbl,par,presig,icount,icgrp,ivgbi
5555 END IF
5556 ELSE
5557 ! variable
5558 WRITE(lup,111) c1,itgbl,par,presig,icount,icgrp
5559 END IF
5560 END DO
5561 ! appearance statistics
5562 IF (icheck > 1) THEN
5563 WRITE(lup,*) '!.'
5564 WRITE(lup,*) '!.Appearance statistics '
5565 WRITE(lup,*) '!. Label First file and record Last file and record #files #paired-par'
5566 DO itgbi=1,ntgb
5567 itpgrp=globalparlabelindex(4,itgbi)
5568 IF (itpgrp > 0) THEN
5569 WRITE(lup,112) globalparlabelindex(1,itgbi), (appearancecounter(itgbi*5+k), k=-4,0), paircounter(itpgrp)
5570 ELSE ! 'empty' parameter
5571 WRITE(lup,112) globalparlabelindex(1,itgbi)
5572 END IF
5573 END DO
5574 END IF
5575 IF (ncgrp > 0) THEN
5576 WRITE(lup,*) '* === constraint groups ==='
5577 IF (icheck == 1) THEN
5578 WRITE(lup,*) '* Group #Cons. Entries First label Last label'
5579 ELSE
5580 WRITE(lup,*) '* Group #Cons. Entries First label Last label Paired label range'
5581 length=ntpgrp+ncgrp
5582 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
5583 END IF
5584 DO icgrp=1, ncgrp
5585 IF (matconsgroups(2,icgrp) <= matconsgroups(3,icgrp)) THEN
5586 label1=globalparlabelindex(1,globalparvartototal(matconsgroups(2,icgrp))) ! first label
5587 label2=globalparlabelindex(1,globalparvartototal(matconsgroups(3,icgrp))) ! last label
5588 ELSE ! empty group/cons.
5589 label1=0
5590 label2=0
5591 END IF
5592 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
5593 WRITE(lup,113) icgrp, ncon,vecconsgroupcounts(icgrp),label1,label2
5594 IF (icheck > 1 .AND. label1 > 0) THEN
5595 ipgrp=globalparlabelindex(4,globalparvartototal(matconsgroups(2,icgrp))) ! first par. group
5596 ! get paired parameter groups
5597 CALL ggbmap(ntpgrp+icgrp,npair,vecpairedpargroups)
5598 vecpairedpargroups(npair+1)=0
5599 ifrst=0
5600 nstep=1
5601 DO j=1, npair
5602 jpgrp=vecpairedpargroups(j)
5603 inext=globaltotindexgroups(1,jpgrp)
5604 DO k=1,globaltotindexgroups(2,jpgrp)
5605 ! end of continous region ?
5606 IF (ifrst /= 0.AND.inext /= (ilast+nstep)) THEN
5607 label1=globalparlabelindex(1,ifrst)
5608 label2=globalparlabelindex(1,ilast)
5609 WRITE(lup,114) label1, label2
5610 ifrst=0
5611 END IF
5612 ! skip 'self-correlations'
5613 IF (globalparcons(inext) /= icgrp) THEN
5614 IF (ifrst == 0) ifrst=inext
5615 ilast=inext
5616 END IF
5617 inext=inext+1
5618 nstep=1
5619 END DO
5620 ! skip 'empty' parameter
5621 IF (jpgrp == vecpairedpargroups(j+1)-1) THEN
5622 nstep=globaltotindexgroups(1,vecpairedpargroups(j+1)) &
5623 -(globaltotindexgroups(1,jpgrp)+globaltotindexgroups(2,jpgrp)-1)
5624 END IF
5625 END DO
5626 IF (ifrst /= 0) THEN
5627 label1=globalparlabelindex(1,ifrst)
5628 label2=globalparlabelindex(1,ilast)
5629 WRITE(lup,114) label1, label2
5630 END IF
5631 END IF
5632 END DO
5633 IF (icheck > 1) THEN
5634 WRITE(lup,*) '*.'
5635 WRITE(lup,*) '*.Appearance statistics '
5636 WRITE(lup,*) '*. Group First file and record Last file and record #files'
5637 DO icgrp=1, ncgrp
5638 WRITE(lup,115) icgrp, (appearancecounter((ntgb+icgrp)*5+k), k=-4,0)
5639 END DO
5640 END IF
5641 END IF
5642
5643 rewind lup
5644 CLOSE(unit=lup)
5645
5646110 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' fixed',i2)
5647111 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' variable')
5648112 FORMAT(' !.',i10,6i11)
5649113 FORMAT(' * ',i6,i8,3i12)
5650114 FORMAT(' *:',48x,i12,' ..',i12)
5651115 FORMAT(' *.',i10,5i11)
5652116 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' redundant')
5653117 FORMAT(' !!',a)
5654END SUBROUTINE prtstat ! print input statistics
5655
5656
5670
5671SUBROUTINE avprds(n,l,x,is,ie,b)
5672 USE mpmod
5673
5674 IMPLICIT NONE
5675 INTEGER(mpi) :: i
5676 INTEGER(mpi) :: ia
5677 INTEGER(mpi) :: ia2
5678 INTEGER(mpi) :: ib
5679 INTEGER(mpi) :: ib2
5680 INTEGER(mpi) :: in
5681 INTEGER(mpi) :: ipg
5682 INTEGER(mpi) :: iproc
5683 INTEGER(mpi) :: ir
5684 INTEGER(mpi) :: j
5685 INTEGER(mpi) :: ja
5686 INTEGER(mpi) :: ja2
5687 INTEGER(mpi) :: jb
5688 INTEGER(mpi) :: jb2
5689 INTEGER(mpi) :: jn
5690 INTEGER(mpi) :: lj
5691
5692 INTEGER(mpi), INTENT(IN) :: n
5693 INTEGER(mpl), INTENT(IN) :: l
5694 REAL(mpd), INTENT(IN) :: x(n)
5695 INTEGER(mpi), INTENT(IN) :: is
5696 INTEGER(mpi), INTENT(IN) :: ie
5697 REAL(mpd), INTENT(OUT) :: b(n)
5698 INTEGER(mpl) :: k
5699 INTEGER(mpl) :: kk
5700 INTEGER(mpl) :: ku
5701 INTEGER(mpl) :: ll
5702 INTEGER(mpl) :: indij
5703 INTEGER(mpl) :: indid
5704 INTEGER(mpl) :: ij
5705 INTEGER(mpi) :: ichunk
5706 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
5707 SAVE
5708 ! ...
5709
5710 ichunk=min((n+mthrd-1)/mthrd/8+1,128)
5711 IF(matsto /= 2) THEN
5712 ! full or unpacked (block diagonal) symmetric matrix
5713 ! parallelize row loop
5714 ! private copy of B(N) for each thread, combined at end, init with 0.
5715 ! slot of 128 'I' for next idle thread
5716 !$OMP PARALLEL DO &
5717 !$OMP PRIVATE(J,IJ) &
5718 !$OMP SCHEDULE(DYNAMIC,ichunk)
5719 DO i=1,n
5720 ij=globalrowoffsets(i+l)+l
5721 DO j=is,min(i,ie)
5722 b(i)=b(i)+globalmatd(ij+j)*x(j)
5723 END DO
5724 END DO
5725 !$OMP END PARALLEL DO
5726
5727 !$OMP PARALLEL DO &
5728 !$OMP PRIVATE(J,IJ) &
5729 !$OMP REDUCTION(+:B) &
5730 !$OMP SCHEDULE(DYNAMIC,ichunk)
5731 DO i=is,ie
5732 ij=globalrowoffsets(i+l)+l
5733 DO j=1,i-1
5734 b(j)=b(j)+globalmatd(ij+j)*x(i)
5735 END DO
5736 END DO
5737 !$OMP END PARALLEL DO
5738 ELSE
5739 ! sparse, compressed matrix
5740 IF(sparsematrixoffsets(2,1) /= n) THEN
5741 CALL peend(24,'Aborted, vector/matrix size mismatch')
5742 stop 'AVPRDS: mismatched vector and matrix'
5743 END IF
5744 ! parallelize row (group) loop
5745 ! slot of 1024 'I' for next idle thread
5746 !$OMP PARALLEL DO &
5747 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
5748 !$OMP PRIVATE(IA,IB,IN,JA,JB,IA2,IB2,JA2,JB2) &
5749 !$OMP REDUCTION(+:B) &
5750 !$OMP SCHEDULE(DYNAMIC,ichunk)
5751 DO ipg=1,napgrp
5752 iproc=0
5753 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5754 ! row group
5755 ia=globalallindexgroups(ipg) ! first (global) row
5756 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
5757 in=ib-ia+1 ! number of rows
5758 ! overlap
5759 ia2=max(ia,is)
5760 ib2=min(ib,ie)
5761 ! diagonal elements
5762 IF (ia2 <= ib2) b(ia2:ib2)=b(ia2:ib2)+globalmatd(ia2:ib2)*x(ia2:ib2)
5763 ! off-diagonals double precision
5764 ir=ipg
5765 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5766 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5767 ku=sparsematrixoffsets(1,ir+1)-kk
5768 indid=kk
5769 indij=ll
5770 IF (ku > 0) THEN
5771 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5772 DO i=ia,ib
5773 IF (i <= ie.AND.i >= is) THEN
5774 DO k=1,ku
5775 j=sparsematrixcolumns(indid+k)
5776 b(j)=b(j)+globalmatd(indij+k)*x(i)
5777 END DO
5778 END IF
5779 DO k=1,ku
5780 j=sparsematrixcolumns(indid+k)
5781 IF (j <= ie.AND.j >= is) THEN
5782 b(i)=b(i)+globalmatd(indij+k)*x(j)
5783 END IF
5784 END DO
5785 indij=indij+ku
5786 END DO
5787 ELSE
5788 ! regions of continous column groups
5789 DO k=2,ku-2,2
5790 j=sparsematrixcolumns(indid+k) ! first group
5791 ja=globalallindexgroups(j) ! first (global) column
5792 lj=sparsematrixcolumns(indid+k-1) ! region offset
5793 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5794 jb=ja+jn-1 ! last (global) column
5795 ja2=max(ja,is)
5796 jb2=min(jb,ie)
5797 IF (ja2 <= jb2) THEN
5798 lj=1 ! index (in group region)
5799 DO i=ia,ib
5800 b(i)=b(i)+dot_product(globalmatd(indij+lj+ja2-ja:indij+lj+jb2-ja),x(ja2:jb2))
5801 lj=lj+jn
5802 END DO
5803 END IF
5804 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5805 lj=1
5806 DO j=ja,jb
5807 b(j)=b(j)+dot_product(globalmatd(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),x(ia2:ib2))
5808 lj=lj+1
5809 END DO
5810 END IF
5811 indij=indij+in*jn
5812 END DO
5813 END IF
5814 END IF
5815 ! mixed precision
5816 IF (nspc > 1) THEN
5817 ir=ipg+napgrp+1 ! off-diagonals single precision
5818 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5819 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5820 ku=sparsematrixoffsets(1,ir+1)-kk
5821 indid=kk
5822 indij=ll
5823 IF (ku == 0) cycle
5824 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5825 DO i=ia,ib
5826 IF (i <= ie.AND.i >= is) THEN
5827 DO k=1,ku
5828 j=sparsematrixcolumns(indid+k)
5829 b(j)=b(j)+globalmatf(indij+k)*x(i)
5830 END DO
5831 END IF
5832 DO k=1,ku
5833 j=sparsematrixcolumns(indid+k)
5834 IF (j <= ie.AND.j >= is) THEN
5835 b(i)=b(i)+globalmatf(indij+k)*x(j)
5836 END IF
5837 END DO
5838 indij=indij+ku
5839 END DO
5840 ELSE
5841 ! regions of continous column groups
5842 DO k=2,ku-2,2
5843 j=sparsematrixcolumns(indid+k) ! first group
5844 ja=globalallindexgroups(j) ! first (global) column
5845 lj=sparsematrixcolumns(indid+k-1) ! region offset
5846 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5847 jb=ja+jn-1 ! last (global) column
5848 ja2=max(ja,is)
5849 jb2=min(jb,ie)
5850 IF (ja2 <= jb2) THEN
5851 lj=1 ! index (in group region)
5852 DO i=ia,ib
5853 b(i)=b(i)+dot_product(real(globalmatf(indij+lj+ja2-ja:indij+lj+jb2-ja),mpd),x(ja2:jb2))
5854 lj=lj+jn
5855 END DO
5856 END IF
5857 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5858 lj=1
5859 DO j=ja,jb
5860 b(j)=b(j)+dot_product(real(globalmatf(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),mpd),x(ia2:ib2))
5861 lj=lj+1
5862 END DO
5863 END IF
5864 indij=indij+in*jn
5865 END DO
5866 END IF
5867 END IF
5868 END DO
5869 ENDIF
5870
5871END SUBROUTINE avprds
5872
5884
5885SUBROUTINE avprd0(n,l,x,b)
5886 USE mpmod
5887
5888 IMPLICIT NONE
5889 INTEGER(mpi) :: i
5890 INTEGER(mpi) :: ia
5891 INTEGER(mpi) :: ib
5892 INTEGER(mpi) :: in
5893 INTEGER(mpi) :: ipg
5894 INTEGER(mpi) :: iproc
5895 INTEGER(mpi) :: ir
5896 INTEGER(mpi) :: j
5897 INTEGER(mpi) :: ja
5898 INTEGER(mpi) :: jb
5899 INTEGER(mpi) :: jn
5900 INTEGER(mpi) :: lj
5901
5902 INTEGER(mpi), INTENT(IN) :: n
5903 INTEGER(mpl), INTENT(IN) :: l
5904 REAL(mpd), INTENT(IN) :: x(n)
5905 REAL(mpd), INTENT(OUT) :: b(n)
5906 INTEGER(mpl) :: k
5907 INTEGER(mpl) :: kk
5908 INTEGER(mpl) :: ku
5909 INTEGER(mpl) :: ll
5910 INTEGER(mpl) :: indij
5911 INTEGER(mpl) :: indid
5912 INTEGER(mpl) :: ij
5913 INTEGER(mpi) :: ichunk
5914 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
5915 SAVE
5916 ! ...
5917 !$ DO i=1,n
5918 !$ b(i)=0.0_mpd ! reset 'global' B()
5919 !$ END DO
5920 ichunk=min((n+mthrd-1)/mthrd/8+1,1024)
5921 IF(matsto /= 2) THEN
5922 ! full or unpacked (block diagonal) symmetric matrix
5923 ! parallelize row loop
5924 ! private copy of B(N) for each thread, combined at end, init with 0.
5925 ! slot of 1024 'I' for next idle thread
5926 !$OMP PARALLEL DO &
5927 !$OMP PRIVATE(J,IJ) &
5928 !$OMP REDUCTION(+:B) &
5929 !$OMP SCHEDULE(DYNAMIC,ichunk)
5930 DO i=1,n
5931 ij=globalrowoffsets(i+l)+l
5932 b(i)=globalmatd(ij+i)*x(i)
5933 DO j=1,i-1
5934 b(j)=b(j)+globalmatd(ij+j)*x(i)
5935 b(i)=b(i)+globalmatd(ij+j)*x(j)
5936 END DO
5937 END DO
5938 !$OMP END PARALLEL DO
5939 ELSE
5940 ! sparse, compressed matrix
5941 IF(sparsematrixoffsets(2,1) /= n) THEN
5942 CALL peend(24,'Aborted, vector/matrix size mismatch')
5943 stop 'AVPRD0: mismatched vector and matrix'
5944 END IF
5945 ! parallelize row (group) loop
5946 ! slot of 1024 'I' for next idle thread
5947 !$OMP PARALLEL DO &
5948 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
5949 !$OMP PRIVATE(IA,IB,IN,JA,JB) &
5950 !$OMP REDUCTION(+:B) &
5951 !$OMP SCHEDULE(DYNAMIC,ichunk)
5952 DO ipg=1,napgrp
5953 iproc=0
5954 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5955 ! row group
5956 ia=globalallindexgroups(ipg) ! first (global) row
5957 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
5958 in=ib-ia+1 ! number of rows
5959 !
5960 ! diagonal elements
5961 b(ia:ib)=globalmatd(ia:ib)*x(ia:ib)
5962 ! off-diagonals double precision
5963 ir=ipg
5964 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5965 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5966 ku=sparsematrixoffsets(1,ir+1)-kk
5967 indid=kk
5968 indij=ll
5969 IF (ku > 0) THEN
5970 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5971 DO i=ia,ib
5972 DO k=1,ku
5973 j=sparsematrixcolumns(indid+k)
5974 b(j)=b(j)+globalmatd(indij+k)*x(i)
5975 b(i)=b(i)+globalmatd(indij+k)*x(j)
5976 END DO
5977 indij=indij+ku
5978 END DO
5979 ELSE
5980 ! regions of continous column groups
5981 DO k=2,ku-2,2
5982 j=sparsematrixcolumns(indid+k) ! first group
5983 ja=globalallindexgroups(j) ! first (global) column
5984 lj=sparsematrixcolumns(indid+k-1) ! region offset
5985 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5986 jb=ja+jn-1 ! last (global) column
5987 lj=1 ! index (in group region)
5988 DO i=ia,ib
5989 b(i)=b(i)+dot_product(globalmatd(indij+lj:indij+lj+jn-1),x(ja:jb))
5990 lj=lj+jn
5991 END DO
5992 IF (mextnd == 0) THEN
5993 lj=1
5994 DO j=ja,jb
5995 b(j)=b(j)+dot_product(globalmatd(indij+lj:indij+jn*in:jn),x(ia:ib))
5996 lj=lj+1
5997 END DO
5998 END IF
5999 indij=indij+in*jn
6000 END DO
6001 END IF
6002 END IF
6003 ! mixed precision
6004 IF (nspc > 1) THEN
6005 ir=ipg+napgrp+1 ! off-diagonals single precision
6006 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6007 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6008 ku=sparsematrixoffsets(1,ir+1)-kk
6009 indid=kk
6010 indij=ll
6011 IF (ku == 0) cycle
6012 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6013 DO i=ia,ib
6014 DO k=1,ku
6015 j=sparsematrixcolumns(indid+k)
6016 b(j)=b(j)+real(globalmatf(indij+k),mpd)*x(i)
6017 b(i)=b(i)+real(globalmatf(indij+k),mpd)*x(j)
6018 END DO
6019 indij=indij+ku
6020 END DO
6021 ELSE
6022 ! regions of continous column groups
6023 DO k=2,ku-2,2
6024 j=sparsematrixcolumns(indid+k) ! first group
6025 ja=globalallindexgroups(j) ! first (global) column
6026 lj=sparsematrixcolumns(indid+k-1) ! region offset
6027 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6028 jb=ja+jn-1 ! last (global) column
6029 lj=1 ! index (in group region)
6030 DO i=ia,ib
6031 b(i)=b(i)+dot_product(real(globalmatf(indij+lj:indij+lj+jn-1),mpd),x(ja:jb))
6032 lj=lj+jn
6033 END DO
6034 IF (mextnd == 0) THEN
6035 lj=1
6036 DO j=ja,jb
6037 b(j)=b(j)+dot_product(real(globalmatf(indij+lj:indij+jn*in:jn),mpd),x(ia:ib))
6038 lj=lj+1
6039 END DO
6040 END IF
6041 indij=indij+in*jn
6042 END DO
6043 END IF
6044 END IF
6045 END DO
6046 ENDIF
6047
6048END SUBROUTINE avprd0
6049
6050
6053SUBROUTINE anasps
6054 USE mpmod
6055
6056 IMPLICIT NONE
6057 INTEGER(mpi) :: ia
6058 INTEGER(mpi) :: ib
6059 INTEGER(mpi) :: ipg
6060 INTEGER(mpi) :: ir
6061 INTEGER(mpi) :: ispc
6062 INTEGER(mpi) :: lj
6063 REAL(mps) :: avg
6064
6065
6066 INTEGER(mpl) :: in
6067 INTEGER(mpl) :: jn
6068 INTEGER(mpl) :: k
6069 INTEGER(mpl) :: kk
6070 INTEGER(mpl) :: ku
6071 INTEGER(mpl) :: ll
6072 INTEGER(mpl) :: indid
6073 INTEGER(mpl), DIMENSION(12) :: icount
6074 SAVE
6075
6076 ! require sparse storage
6077 IF(matsto /= 2) RETURN
6078 ! reset
6079 icount=0
6080 icount(4)=huge(icount(4))
6081 icount(7)=huge(icount(7))
6082 icount(10)=huge(icount(10))
6083 ! loop over precisions
6084 DO ispc=1,nspc
6085 ! loop over row groups
6086 DO ipg=1,napgrp
6087 ! row group
6088 ia=globalallindexgroups(ipg) ! first (global) row
6089 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6090 in=ib-ia+1 ! number of rows
6091
6092 ir=ipg+(ispc-1)*(napgrp+1)
6093 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6094 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6095 ku=sparsematrixoffsets(1,ir+1)-kk
6096 indid=kk
6097 IF (ku == 0) cycle
6098 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6099 icount(1)=icount(1)+in
6100 icount(2)=icount(2)+in*ku
6101 ELSE
6102 ! regions of continous column groups
6103 DO k=2,ku-2,2
6104 lj=sparsematrixcolumns(indid+k-1) ! region offset
6105 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6106 icount(3)=icount(3)+1 ! block (region) counter
6107 icount(4)=min(icount(4),jn) ! min number of columns per block (region)
6108 icount(5)=icount(5)+jn ! sum number of columns per block (region)
6109 icount(6)=max(icount(6),jn) ! max number of columns per block (region)
6110 icount(7)=min(icount(7),in) ! min number of rows per block (region)
6111 icount(8)=icount(8)+in ! sum number of rows per block (region)
6112 icount(9)=max(icount(9),in) ! max number of rows per block (region)
6113 icount(10)=min(icount(10),in*jn) ! min number of elements per block (region)
6114 icount(11)=icount(11)+in*jn ! sum number of elements per block (region)
6115 icount(12)=max(icount(12),in*jn) ! max number of elements per block (region)
6116 END DO
6117 END IF
6118 END DO
6119 END DO
6120
6121 WRITE(*,*) "analysis of sparsity structure"
6122 IF (icount(1) > 0) THEN
6123 WRITE(*,101) "rows without compression/blocks ", icount(1)
6124 WRITE(*,101) " contained elements ", icount(2)
6125 ENDIF
6126 WRITE(*,101) "number of block matrices ", icount(3)
6127 avg=real(icount(5),mps)/real(icount(3),mps)
6128 WRITE(*,101) "number of columns (min,mean,max) ", icount(4), avg, icount(6)
6129 avg=real(icount(8),mps)/real(icount(3),mps)
6130 WRITE(*,101) "number of rows (min,mean,max) ", icount(7), avg, icount(9)
6131 avg=real(icount(11),mps)/real(icount(3),mps)
6132 WRITE(*,101) "number of elements (min,mean,max) ", icount(10), avg, icount(12)
6133101 FORMAT(2x,a34,i10,f10.3,i10)
6134
6135END SUBROUTINE anasps
6136
6146
6147SUBROUTINE avprod(n,x,b)
6148 USE mpmod
6149
6150 IMPLICIT NONE
6151
6152 INTEGER(mpi), INTENT(IN) :: n
6153 REAL(mpd), INTENT(IN) :: x(n)
6154 REAL(mpd), INTENT(OUT) :: b(n)
6155
6156 SAVE
6157 ! ...
6158 IF(n > nagb) THEN
6159 CALL peend(24,'Aborted, vector/matrix size mismatch')
6160 stop 'AVPROD: mismatched vector and matrix'
6161 END IF
6162 ! input to AVPRD0
6163 vecxav(1:n)=x
6164 vecxav(n+1:nagb)=0.0_mpd
6165 !use elimination for constraints ?
6166 IF(n < nagb) CALL qlmlq(vecxav,1,.false.) ! Q*x
6167 ! calclulate vecBav=globalMat*vecXav
6168 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
6169 !use elimination for constraints ?
6170 IF(n < nagb) CALL qlmlq(vecbav,1,.true.) ! Q^t*x
6171 ! output from AVPRD0
6172 b=vecbav(1:n)
6173
6174END SUBROUTINE avprod
6175
6176
6186
6187SUBROUTINE ijpgrp(itema,itemb,ij,lr,iprc)
6188 USE mpmod
6189
6190 IMPLICIT NONE
6191 INTEGER(mpi) :: ispc
6192 INTEGER(mpi) :: item1
6193 INTEGER(mpi) :: item2
6194 INTEGER(mpi) :: itemc
6195 INTEGER(mpi) :: jtem
6196 INTEGER(mpi) :: jtemn
6197 INTEGER(mpi) :: np
6198
6199 INTEGER(mpi), INTENT(IN) :: itema
6200 INTEGER(mpi), INTENT(IN) :: itemb
6201 INTEGER(mpl), INTENT(OUT) :: ij
6202 INTEGER(mpi), INTENT(OUT) :: lr
6203 INTEGER(mpi), INTENT(OUT) :: iprc
6204
6205 INTEGER(mpl) :: k
6206 INTEGER(mpl) :: kk
6207 INTEGER(mpl) :: kl
6208 INTEGER(mpl) :: ku
6209 INTEGER(mpl) :: ll
6210 ! ...
6211 ij=0
6212 lr=0
6213 iprc=0
6214 item1=max(itema,itemb) ! larger index
6215 item2=min(itema,itemb) ! smaller index
6216 IF(item2 <= 0.OR.item1 > napgrp) RETURN
6217 np=globalallindexgroups(item1+1)-globalallindexgroups(item1) ! size of group item1
6218 ! loop over precisions
6219 outer: DO ispc=1,nspc
6220 kk=sparsematrixoffsets(1,item1) ! offset (column lists)
6221 ll=sparsematrixoffsets(2,item1) ! offset (matrix)
6222 kl=1
6223 ku=sparsematrixoffsets(1,item1+1)-kk
6224 item1=item1+napgrp+1
6225 iprc=ispc
6226 IF (sparsematrixcolumns(kk+1) == 0) THEN ! compression ?
6227 ! compressed (list of continous regions of parameter groups (pairs of offset and 1. group index)
6228 kl=2
6229 ku=ku-2
6230 IF(ku < kl) cycle outer ! not found
6231 DO
6232 k=2*((kl+ku)/4) ! binary search
6233 jtem=sparsematrixcolumns(kk+k) ! first column (group) of region
6234 jtemn=sparsematrixcolumns(kk+k+2) ! first column (group) after region
6235 IF(item2 >= jtem.AND.item2 < jtemn) THEN
6236 ! length of region
6237 lr=sparsematrixcolumns(kk+k+1)-sparsematrixcolumns(kk+k-1)
6238 IF (globalallindexgroups(item2)-globalallindexgroups(jtem) >= lr) cycle outer ! outside region
6239 EXIT ! found
6240 END IF
6241 IF(item2 < jtem) THEN
6242 ku=k-2
6243 ELSE IF(item2 >= jtemn) THEN
6244 kl=k+2
6245 END IF
6246 IF(kl <= ku) cycle
6247 cycle outer ! not found
6248 END DO
6249 ! group offset in row
6250 ij=sparsematrixcolumns(kk+k-1)
6251 ! absolute offset
6252 ij=ll+ij*np+globalallindexgroups(item2)-globalallindexgroups(jtem)+1
6253
6254 ELSE
6255 ! simple column list
6256 itemc=globalallindexgroups(item2) ! first (col) index of group
6257 lr=int(ku,mpi) ! number of columns
6258 IF(ku < kl) cycle outer ! not found
6259 DO
6260 k=(kl+ku)/2 ! binary search
6261 jtem=sparsematrixcolumns(kk+k)
6262 IF(itemc == jtem) EXIT ! found
6263 IF(itemc < jtem) THEN
6264 ku=k-1
6265 ELSE IF(itemc > jtem) THEN
6266 kl=k+1
6267 END IF
6268 IF(kl <= ku) cycle
6269 cycle outer ! not found
6270 END DO
6271 ij=ll+k
6272
6273 END IF
6274 RETURN
6275 END DO outer
6276
6277END SUBROUTINE ijpgrp
6278
6284
6285FUNCTION ijprec(itema,itemb)
6286 USE mpmod
6287
6288 IMPLICIT NONE
6289
6290 INTEGER(mpi) :: lr
6291 INTEGER(mpl) :: ij
6292
6293 INTEGER(mpi), INTENT(IN) :: itema
6294 INTEGER(mpi), INTENT(IN) :: itemb
6295 INTEGER(mpi) :: ijprec
6296
6297 ! ...
6298 ijprec=1
6299 IF (matsto == 2.AND.nspc > 1) THEN ! sparse storage with mixed precision
6300 ! check groups
6301 CALL ijpgrp(itema,itemb,ij,lr,ijprec)
6302 END IF
6303
6304END FUNCTION ijprec
6305
6313
6314FUNCTION ijadd(itema,itemb) ! index using "d" and "z"
6315 USE mpmod
6316
6317 IMPLICIT NONE
6318
6319 INTEGER(mpi) :: item1
6320 INTEGER(mpi) :: item2
6321 INTEGER(mpi) :: ipg1
6322 INTEGER(mpi) :: ipg2
6323 INTEGER(mpi) :: lr
6324 INTEGER(mpi) :: iprc
6325
6326 INTEGER(mpi), INTENT(IN) :: itema
6327 INTEGER(mpi), INTENT(IN) :: itemb
6328
6329 INTEGER(mpl) :: ijadd
6330 INTEGER(mpl) :: ij
6331 ! ...
6332 ijadd=0
6333 item1=max(itema,itemb) ! larger index
6334 item2=min(itema,itemb) ! smaller index
6335 !print *, ' ijadd ', item1, item2
6336 IF(item2 <= 0.OR.item1 > nagb) RETURN
6337 IF(item1 == item2) THEN ! diagonal element
6338 ijadd=item1
6339 RETURN
6340 END IF
6341 ! ! off-diagonal element
6342 ! get parameter groups
6343 ipg1=globalallpartogroup(item1)
6344 ipg2=globalallpartogroup(item2)
6345 ! get offset for groups
6346 CALL ijpgrp(ipg1,ipg2,ij,lr,iprc)
6347 IF (ij == 0) RETURN
6348 ! add offset inside groups
6349 ijadd=ij+(item2-globalallindexgroups(ipg2))+(item1-globalallindexgroups(ipg1))*lr
6350 ! reduced precision?
6351 IF (iprc > 1) ijadd=-ijadd
6352
6353END FUNCTION ijadd
6354
6362
6363FUNCTION ijcsr3(itema,itemb) ! index using "d" and "z"
6364 USE mpmod
6365
6366 IMPLICIT NONE
6367
6368 INTEGER(mpi) :: item1
6369 INTEGER(mpi) :: item2
6370 INTEGER(mpi) :: jtem
6371
6372 INTEGER(mpi), INTENT(IN) :: itema
6373 INTEGER(mpi), INTENT(IN) :: itemb
6374
6375 INTEGER(mpl) :: ijcsr3
6376 INTEGER(mpl) :: kk
6377 INTEGER(mpl) :: ks
6378 INTEGER(mpl) :: ke
6379
6380 ! ...
6381 ijcsr3=0
6382 item1=max(itema,itemb) ! larger index
6383 item2=min(itema,itemb) ! smaller index
6384 !print *, ' ijadd ', item1, item2
6385 IF(item2 <= 0.OR.item1 > nagb) RETURN
6386 ! start of column list for row
6387 ks=csr3rowoffsets(item2)
6388 ! end of column list for row
6389 ke=csr3rowoffsets(item2+1)-1
6390 ! binary search
6391 IF(ke < ks) THEN
6392 ! empty list
6393 print *, ' IJCSR3 empty list ', item1, item2, ks, ke
6394 CALL peend(23,'Aborted, bad matrix index')
6395 stop 'ijcsr3: empty list'
6396 ENDIF
6397 DO
6398 kk=(ks+ke)/2 ! center of rgion
6399 jtem=int(csr3columnlist(kk),mpi)
6400 IF(item1 == jtem) EXIT ! found
6401 IF(item1 < jtem) THEN
6402 ke=kk-1
6403 ELSE
6404 ks=kk+1
6405 END IF
6406 IF(ks <= ke) cycle
6407 ! not found
6408 print *, ' IJCSR3 not found ', item1, item2, ks, ke
6409 CALL peend(23,'Aborted, bad matrix index')
6410 stop 'ijcsr3: not found'
6411 END DO
6412 ijcsr3=kk
6413END FUNCTION ijcsr3
6414
6420
6421FUNCTION matij(itema,itemb)
6422 USE mpmod
6423
6424 IMPLICIT NONE
6425
6426 INTEGER(mpi) :: item1
6427 INTEGER(mpi) :: item2
6428 INTEGER(mpl) :: i
6429 INTEGER(mpl) :: j
6430 INTEGER(mpl) :: ij
6431 INTEGER(mpl) :: ijadd
6432 INTEGER(mpl) :: ijcsr3
6433
6434 INTEGER(mpi), INTENT(IN) :: itema
6435 INTEGER(mpi), INTENT(IN) :: itemb
6436
6437 REAL(mpd) :: matij
6438 ! ...
6439 matij=0.0_mpd
6440 item1=max(itema,itemb) ! larger index
6441 item2=min(itema,itemb) ! smaller index
6442 IF(item2 <= 0.OR.item1 > nagb) RETURN
6443
6444 i=item1
6445 j=item2
6446
6447 IF(matsto < 2) THEN ! full or unpacked (block diagonal) symmetric matrix
6448 ij=globalrowoffsets(i)+j
6449 matij=globalmatd(ij)
6450 ELSE IF(matsto ==2) THEN ! sparse symmetric matrix (custom)
6451 ij=ijadd(item1,item2) ! inline code requires same time
6452 IF(ij > 0) THEN
6453 matij=globalmatd(ij)
6454 ELSE IF (ij < 0) THEN
6455 matij=real(globalmatf(-ij),mpd)
6456 END IF
6457 ELSE ! sparse symmetric matrix (CSR3)
6458 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
6459 ij=ijcsr3(item1,item2) ! inline code requires same time
6460 IF(ij > 0) matij=globalmatd(ij)
6461 ELSE ! sparse symmetric matrix (BSR3)
6462 ! block index
6463 ij=ijcsr3((item1-1)/matbsz+1,(item2-1)/matbsz+1)
6464 IF (ij > 0) THEN
6465 ! index of first element in block
6466 ij=(ij-1)*matbsz*matbsz+1
6467 ! adjust index for position in block
6468 ij=ij+mod(item1-1,matbsz)*matbsz+mod(item2-1,matbsz)
6469 matij=globalmatd(ij)
6470 ENDIF
6471 END IF
6472 END IF
6473
6474END FUNCTION matij
6475
6478
6479SUBROUTINE mhalf2
6480 USE mpmod
6481
6482 IMPLICIT NONE
6483 INTEGER(mpi) :: i
6484 INTEGER(mpi) :: ia
6485 INTEGER(mpi) :: ib
6486 INTEGER(mpi) :: ichunk
6487 INTEGER(mpi) :: in
6488 INTEGER(mpi) :: ipg
6489 INTEGER(mpi) :: ir
6490 INTEGER(mpi) :: ispc
6491 INTEGER(mpi) :: j
6492 INTEGER(mpi) :: ja
6493 INTEGER(mpi) :: jb
6494 INTEGER(mpi) :: jn
6495 INTEGER(mpi) :: lj
6496
6497 INTEGER(mpl) :: ij
6498 INTEGER(mpl) :: ijadd
6499 INTEGER(mpl) :: k
6500 INTEGER(mpl) :: kk
6501 INTEGER(mpl) :: ku
6502 INTEGER(mpl) :: ll
6503 ! ...
6504
6505 ichunk=min((napgrp+mthrd-1)/mthrd/8+1,1024)
6506
6507 DO ispc=1,nspc
6508 ! parallelize row loop
6509 ! slot of 1024 'I' for next idle thread
6510 !$OMP PARALLEL DO &
6511 !$OMP PRIVATE(I,IR,K,KK,LL,KU,IJ,J,LJ) &
6512 !$OMP PRIVATE(IA,IB,IN,JA,JB,JN) &
6513 !$OMP SCHEDULE(DYNAMIC,ichunk)
6514 DO ipg=1,napgrp
6515 ! row group
6516 ia=globalallindexgroups(ipg) ! first (global) row
6517 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6518 in=ib-ia+1 ! number of rows
6519 !
6520 ir=ipg+(ispc-1)*(napgrp+1)
6521 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6522 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6523 ku=sparsematrixoffsets(1,ir+1)-kk
6524 ! regions of continous column groups
6525 DO k=2,ku-2,2
6526 j=sparsematrixcolumns(kk+k) ! first group
6527 ja=globalallindexgroups(j) ! first (global) column
6528 lj=sparsematrixcolumns(kk+k-1) ! region offset
6529 jn=sparsematrixcolumns(kk+k+1)-lj ! number of columns
6530 jb=ja+jn-1 ! last (global) column
6531 ! skip first half
6532 IF (sparsematrixcolumns(kk+k+2) <= ipg) THEN
6533 ll=ll+in*jn
6534 cycle
6535 END IF
6536 ! at diagonal or in second half
6537 DO i=ia,ib ! loop over rows
6538 DO j=ja,jb ! loop over columns
6539 ll=ll+1
6540 IF (j > i) THEN
6541 ij=ijadd(i,j)
6542 IF (ispc==1) THEN
6543 globalmatd(ll)=globalmatd(ij)
6544 ELSE
6545 globalmatf(ll)=globalmatf(-ij)
6546 END IF
6547 END IF
6548 END DO
6549 END DO
6550 END DO
6551 END DO
6552 !$OMP END PARALLEL DO
6553 END DO
6554
6555END SUBROUTINE mhalf2
6556
6565
6566SUBROUTINE sechms(deltat,nhour,minut,secnd)
6567 USE mpdef
6568
6569 IMPLICIT NONE
6570 REAL(mps), INTENT(IN) :: deltat
6571 INTEGER(mpi), INTENT(OUT) :: minut
6572 INTEGER(mpi), INTENT(OUT):: nhour
6573 REAL(mps), INTENT(OUT):: secnd
6574 INTEGER(mpi) :: nsecd
6575 ! DELTAT = time in sec -> NHOUR,MINUT,SECND
6576 ! ...
6577 nsecd=nint(deltat,mpi) ! -> integer
6578 nhour=nsecd/3600
6579 minut=nsecd/60-60*nhour
6580 secnd=deltat-60*(minut+60*nhour)
6581END SUBROUTINE sechms
6582
6610
6611INTEGER(mpi) FUNCTION inone(item) ! translate 1-D identifier to nrs
6612 USE mpmod
6613 USE mpdalc
6614
6615 IMPLICIT NONE
6616 INTEGER(mpi), INTENT(IN) :: item
6617 INTEGER(mpi) :: j
6618 INTEGER(mpi) :: k
6619 INTEGER(mpi) :: iprime
6620 INTEGER(mpl) :: length
6621 INTEGER(mpl), PARAMETER :: four = 4
6622
6623 inone=0
6624 !print *, ' INONE ', item
6625 IF(item <= 0) RETURN
6626 IF(globalparheader(-1) == 0) THEN
6627 length=128 ! initial number
6628 CALL mpalloc(globalparlabelindex,four,length,'INONE: label & index')
6629 CALL mpalloc(globalparlabelcounter,length,'INONE: counter') ! updated in pargrp
6630 CALL mpalloc(globalparhashtable,2*length,'INONE: hash pointer')
6631 globalparhashtable = 0
6632 globalparheader(-0)=int(length,mpi) ! length of labels/indices
6633 globalparheader(-1)=0 ! number of stored items
6634 globalparheader(-2)=0 ! =0 during build-up
6635 globalparheader(-3)=int(length,mpi) ! next number
6636 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number
6637 globalparheader(-5)=0 ! number of overflows
6638 globalparheader(-6)=0 ! nr of variable parameters
6639 globalparheader(-8)=0 ! number of sorted items
6640 END IF
6641 outer: DO
6642 j=1+mod(item,globalparheader(-4))+globalparheader(-0)
6643 inner: DO ! normal case: find item
6644 k=j
6645 j=globalparhashtable(k)
6646 IF(j == 0) EXIT inner ! unused hash code
6647 IF(item == globalparlabelindex(1,j)) EXIT outer ! found
6648 END DO inner
6649 ! not found
6650 IF(globalparheader(-1) == globalparheader(-0).OR.globalparheader(-2) /= 0) THEN
6651 globalparheader(-5)=globalparheader(-5)+1 ! overflow
6652 j=0
6653 RETURN
6654 END IF
6655 globalparheader(-1)=globalparheader(-1)+1 ! increase number of elements
6656 globalparheader(-3)=globalparheader(-1)
6657 j=globalparheader(-1)
6658 globalparhashtable(k)=j ! hash index
6659 globalparlabelindex(1,j)=item ! add new item
6660 globalparlabelindex(2,j)=0 ! reset index (for variable par.)
6661 globalparlabelindex(3,j)=0 ! reset group info (first label)
6662 globalparlabelindex(4,j)=0 ! reset group info (group index)
6663 globalparlabelcounter(j)=0 ! reset (long) counter
6664 IF(globalparheader(-1) /= globalparheader(-0)) EXIT outer
6665 ! update with larger dimension and redefine index
6666 globalparheader(-3)=globalparheader(-3)*2
6667 CALL upone
6668 IF (lvllog > 1) WRITE(lunlog,*) 'INONE: array increased to', &
6669 globalparheader(-3),' words'
6670 END DO outer
6671
6672 ! counting now in pargrp
6673 !IF(globalParHeader(-2) == 0) THEN
6674 ! globalParLabelIndex(2,j)=globalParLabelIndex(2,j)+1 ! increase counter
6675 ! globalParHeader(-7)=globalParHeader(-7)+1
6676 !END IF
6677 inone=j
6678END FUNCTION inone
6679
6681SUBROUTINE upone
6682 USE mpmod
6683 USE mpdalc
6684
6685 IMPLICIT NONE
6686 INTEGER(mpi) :: i
6687 INTEGER(mpi) :: j
6688 INTEGER(mpi) :: k
6689 INTEGER(mpi) :: iprime
6690 INTEGER(mpi) :: nused
6691 LOGICAL :: finalUpdate
6692 INTEGER(mpl) :: oldLength
6693 INTEGER(mpl) :: newLength
6694 INTEGER(mpl), PARAMETER :: four = 4
6695 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArr
6696 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: tempVec
6697 SAVE
6698 ! ...
6699 finalupdate=(globalparheader(-3) == globalparheader(-1))
6700 IF(finalupdate) THEN ! final (cleanup) call
6701 IF (globalparheader(-1) > globalparheader(-8)) THEN
6702 CALL sort22l(globalparlabelindex,globalparlabelcounter,globalparheader(-1)) ! sort items
6703 globalparheader(-8)=globalparheader(-1)
6704 END IF
6705 END IF
6706 ! save old LabelIndex
6707 nused = globalparheader(-1)
6708 oldlength = globalparheader(-0)
6709 CALL mpalloc(temparr,four,oldlength,'INONE: temp array')
6710 temparr(:,1:nused)=globalparlabelindex(:,1:nused)
6711 CALL mpalloc(tempvec,oldlength,'INONE: temp vector')
6712 tempvec(1:nused)=globalparlabelcounter(1:nused)
6713 CALL mpdealloc(globalparlabelindex)
6714 CALL mpdealloc(globalparlabelcounter)
6715 CALL mpdealloc(globalparhashtable)
6716 ! create new LabelIndex
6717 newlength = globalparheader(-3)
6718 CALL mpalloc(globalparlabelindex,four,newlength,'INONE: label & index')
6719 CALL mpalloc(globalparlabelcounter,newlength,'INONE: counter')
6720 CALL mpalloc(globalparhashtable,2*newlength,'INONE: hash pointer')
6721 globalparhashtable = 0
6722 globalparlabelindex(:,1:nused) = temparr(:,1:nused) ! copy back saved content
6723 globalparlabelcounter(1:nused) = tempvec(1:nused) ! copy back saved content
6724 CALL mpdealloc(tempvec)
6725 CALL mpdealloc(temparr)
6726 globalparheader(-0)=int(newlength,mpi) ! length of labels/indices
6727 globalparheader(-3)=globalparheader(-1)
6728 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number < LNDA
6729 ! redefine hash
6730 outer: DO i=1,globalparheader(-1)
6731 j=1+mod(globalparlabelindex(1,i),globalparheader(-4))+globalparheader(-0)
6732 inner: DO
6733 k=j
6734 j=globalparhashtable(k)
6735 IF(j == 0) EXIT inner ! unused hash code
6736 IF(j == i) cycle outer ! found
6737 ENDDO inner
6738 globalparhashtable(k)=i
6739 END DO outer
6740 IF(.NOT.finalupdate) RETURN
6741
6742 globalparheader(-2)=1 ! set flag to inhibit further updates
6743 IF (lvllog > 1) THEN
6744 WRITE(lunlog,*) ' '
6745 WRITE(lunlog,*) 'INONE: array reduced to',newlength,' words'
6746 WRITE(lunlog,*) 'INONE:',globalparheader(-1),' items stored.'
6747 END IF
6748END SUBROUTINE upone ! update, redefine
6749
6751SUBROUTINE useone
6752 USE mpmod
6753
6754 IMPLICIT NONE
6755 INTEGER(mpi) :: i
6756 INTEGER(mpi) :: j
6757 INTEGER(mpi) :: k
6758 SAVE
6759 ! ...
6760 IF (globalparheader(-1) > globalparheader(-8)) THEN
6761 CALL sort22l(globalparlabelindex,globalparlabelcounter,globalparheader(-1)) ! sort items
6762 ! redefine hash
6763 globalparhashtable = 0
6764 outer: DO i=1,globalparheader(-1)
6765 j=1+mod(globalparlabelindex(1,i),globalparheader(-4))+globalparheader(-0)
6766 inner: DO
6767 k=j
6768 j=globalparhashtable(k)
6769 IF(j == 0) EXIT inner ! unused hash code
6770 IF(j == i) cycle outer ! found
6771 ENDDO inner
6772 globalparhashtable(k)=i
6773 END DO outer
6774 globalparheader(-8)=globalparheader(-1)
6775 END IF
6776END SUBROUTINE useone ! make usable
6777
6782
6783INTEGER(mpi) FUNCTION iprime(n)
6784 USE mpdef
6785
6786 IMPLICIT NONE
6787 INTEGER(mpi), INTENT(IN) :: n
6788 INTEGER(mpi) :: nprime
6789 INTEGER(mpi) :: nsqrt
6790 INTEGER(mpi) :: i
6791 ! ...
6792 SAVE
6793 nprime=n ! max number
6794 IF(mod(nprime,2) == 0) nprime=nprime+1 ! ... odd number
6795 outer: DO
6796 nprime=nprime-2 ! next lower odd number
6797 nsqrt=int(sqrt(real(nprime,mps)),mpi)
6798 DO i=3,nsqrt,2 !
6799 IF(i*(nprime/i) == nprime) cycle outer ! test prime number
6800 END DO
6801 EXIT outer ! found
6802 END DO outer
6803 iprime=nprime
6804END FUNCTION iprime
6805
6815SUBROUTINE loop1
6816 USE mpmod
6817 USE mpdalc
6818
6819 IMPLICIT NONE
6820 INTEGER(mpi) :: i
6821 INTEGER(mpi) :: idum
6822 INTEGER(mpi) :: in
6823 INTEGER(mpi) :: indab
6824 INTEGER(mpi) :: itgbi
6825 INTEGER(mpi) :: itgbl
6826 INTEGER(mpi) :: ivgbi
6827 INTEGER(mpi) :: j
6828 INTEGER(mpi) :: jgrp
6829 INTEGER(mpi) :: lgrp
6830 INTEGER(mpi) :: mqi
6831 INTEGER(mpi) :: nc31
6832 INTEGER(mpi) :: nr
6833 INTEGER(mpi) :: nwrd
6834 INTEGER(mpi) :: inone
6835 REAL(mpd) :: param
6836 REAL(mpd) :: presg
6837 REAL(mpd) :: prewt
6838
6839 INTEGER(mpl) :: length
6840 INTEGER(mpl) :: rows
6841 SAVE
6842 ! ...
6843 WRITE(lunlog,*) ' '
6844 WRITE(lunlog,*) 'LOOP1: starting'
6845 CALL mstart('LOOP1')
6846
6847 ! add labels from parameter, constraints, measurements, comments -------------
6848 DO i=1, lenparameters
6849 idum=inone(listparameters(i)%label)
6850 END DO
6851 DO i=1, lenpresigmas
6852 idum=inone(listpresigmas(i)%label)
6853 END DO
6854 DO i=1, lenconstraints
6855 idum=inone(listconstraints(i)%label)
6856 END DO
6857 DO i=1, lenmeasurements
6858 idum=inone(listmeasurements(i)%label)
6859 END DO
6860 DO i=1, lencomments
6861 idum=inone(listcomments(i)%label)
6862 END DO
6863
6864 IF(globalparheader(-1) /= 0) THEN
6865 WRITE(lunlog,*) 'LOOP1:',globalparheader(-1), ' labels from txt data stored'
6866 END IF
6867 WRITE(lunlog,*) 'LOOP1: reading data files'
6868
6869 neqn=0 ! number of equations
6870 negb=0 ! number of equations with global parameters
6871 ndgb=0 ! number of global derivatives
6872 DO
6873 DO j=1,globalparheader(-1)
6874 globalparlabelindex(2,j)=0 ! reset count
6875 END DO
6876
6877 ! read all data files and add all labels to global labels table ----
6878
6879 IF(mprint /= 0) THEN
6880 WRITE(*,*) 'Read all binary data files:'
6881 END IF
6882 CALL hmpldf(1,'Number of words/record in binary file')
6883 CALL hmpdef(8,0.0,60.0,'not_stored data per record')
6884 ! define read buffer
6885 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
6886 nwrd=nc31+1
6887 length=nwrd*mthrdr
6888 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
6889 nwrd=nc31*10+2+ndimbuf
6890 length=nwrd*mthrdr
6891 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
6892 CALL mpalloc(readbufferdatad,length,'read buffer, double')
6893 ! to read (old) float binary files
6894 length=(ndimbuf+2)*mthrdr
6895 CALL mpalloc(readbufferdataf,length,'read buffer, float')
6896
6897 DO
6898 CALL peread(nr) ! read records
6899 IF (skippedrecords == 0) THEN
6900 CALL peprep(0) ! prepare records
6901 CALL pepgrp ! update parameter group info
6902 END IF
6903 IF(nr <= 0) EXIT ! end of data?
6904 END DO
6905 ! release read buffer
6906 CALL mpdealloc(readbufferdataf)
6907 CALL mpdealloc(readbufferdatad)
6908 CALL mpdealloc(readbufferdatai)
6909 CALL mpdealloc(readbufferpointer)
6910 IF (skippedrecords == 0) THEN
6911 EXIT
6912 ELSE
6913 WRITE(lunlog,*) 'LOOP1: reading data files again'
6914 END IF
6915 END DO
6916
6917 IF(nhistp /= 0) THEN
6918 CALL hmprnt(1)
6919 CALL hmprnt(8)
6920 END IF
6921 CALL hmpwrt(1)
6922 CALL hmpwrt(8)
6923 ntgb = globalparheader(-1) ! total number of labels/parameters
6924 IF (ntgb == 0) THEN
6925 CALL peend(21,'Aborted, no labels/parameters defined')
6926 stop 'LOOP1: no labels/parameters defined'
6927 END IF
6928 CALL upone ! finalize the global label table
6929
6930 WRITE(lunlog,*) 'LOOP1:',ntgb, &
6931 ' is total number NTGB of labels/parameters'
6932 ! histogram number of entries per label ----------------------------
6933 CALL hmpldf(2,'Number of entries per label')
6934 DO j=1,ntgb
6935 CALL hmplnt(2,globalparlabelindex(2,j))
6936 END DO
6937 IF(nhistp /= 0) CALL hmprnt(2) ! print histogram
6938 CALL hmpwrt(2) ! write to his file
6939
6940 ! three subarrays for all global parameters ------------------------
6941 length=ntgb
6942 CALL mpalloc(globalparameter,length,'global parameters')
6943 globalparameter=0.0_mpd
6944 CALL mpalloc(globalparpresigma,length,'pre-sigmas') ! presigmas
6945 globalparpresigma=0.
6946 CALL mpalloc(globalparstart,length,'global parameters at start')
6947 globalparstart=0.
6948 CALL mpalloc(globalparcopy,length,'copy of global parameters')
6949 CALL mpalloc(globalparcons,length,'global parameter constraints')
6950 globalparcons=0
6951 CALL mpalloc(globalparcomments,length,'global parameter comments')
6952 globalparcomments=0
6953
6954 DO i=1,lenparameters ! parameter start values
6955 param=listparameters(i)%value
6956 in=inone(listparameters(i)%label)
6957 IF(in /= 0) THEN
6958 globalparameter(in)=param
6959 globalparstart(in)=param
6960 ENDIF
6961 END DO
6962
6963 DO i=1, lencomments
6964 in=inone(listcomments(i)%label)
6965 IF(in /= 0) globalparcomments(in)=i
6966 END DO
6967
6968 npresg=0
6969 DO i=1,lenpresigmas ! pre-sigma values
6970 presg=listpresigmas(i)%value
6971 in=inone(listpresigmas(i)%label)
6972 IF(in /= 0) THEN
6973 IF(presg > 0.0) npresg=npresg+1 ! FIXME: check if enough 'entries'?
6974 globalparpresigma(in)=presg ! insert pre-sigma 0 or > 0
6975 END IF
6976 END DO
6977 WRITE(lunlog,*) 'LOOP1:',npresg,' is number of pre-sigmas'
6978 WRITE(*,*) 'LOOP1:',npresg,' is number of pre-sigmas'
6979 IF(npresg == 0) WRITE(*,*) 'Warning: no pre-sigmas defined'
6980
6981 ! build constraint groups, check for redundancy constrints
6982 CALL grpcon
6983
6984 ! determine flag variable (active) or fixed (inactive) -------------
6985
6986 indab=0
6987 DO i=1,ntgb
6988 IF (globalparpresigma(i) < 0.0) THEN
6989 globalparlabelindex(2,i)=-1 ! fixed (pre-sigma), not used in matrix (not active)
6990 ELSE IF(globalparlabelcounter(i) < mreqenf) THEN
6991 globalparlabelindex(2,i)=-2 ! fixed (entries cut), not used in matrix (not active)
6992 ELSE IF (globalparcons(i) < 0) THEN
6993 globalparlabelindex(2,i)=-4 ! fixed (redundant), not used in matrix (not active)
6994 ELSE
6995 indab=indab+1
6996 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
6997 END IF
6998 END DO
6999 globalparheader(-6)=indab ! counted variable
7000 nvgb=indab ! nr of variable parameters
7001 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7002 IF(iteren > mreqenf) THEN
7003 IF (mcount == 0) THEN
7004 CALL loop1i ! iterate entries cut
7005 ELSE
7006 WRITE(lunlog,*) 'LOOP1: counting records, NO iteration of entries cut !'
7007 iteren=0
7008 END IF
7009 END IF
7010
7011 ! --- check for parameter groups
7012 CALL hmpdef(15,0.0,120.0,'Number of parameters per group')
7013 ntpgrp=0
7014 DO j=1,ntgb
7015 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7016 ! new group?
7017 IF (globalparlabelindex(1,j) == globalparlabelindex(3,j)) ntpgrp=ntpgrp+1
7018 globalparlabelindex(4,j)=ntpgrp ! relation total index -> group
7019 END DO
7020 ! check variable parameters
7021 nvpgrp=0
7022 lgrp=-1
7023 DO j=1,ntgb
7024 IF (globalparlabelindex(2,j) <= 0) cycle ! skip fixed parameter
7025 ! new group ?
7026 IF (globalparlabelindex(4,j) /= lgrp) nvpgrp=nvpgrp+1
7027 lgrp=globalparlabelindex(4,j)
7028 END DO
7029 length=ntpgrp; rows=2
7030 CALL mpalloc(globaltotindexgroups,rows,length,'parameter groups, 1. index and size')
7031 globaltotindexgroups=0
7032 ! fill
7033 lgrp=-1
7034 DO j=1,ntgb
7035 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7036 jgrp=globalparlabelindex(4,j)
7037 IF (jgrp /= lgrp) globaltotindexgroups(1,jgrp)=j ! first (total) index
7038 globaltotindexgroups(2,jgrp)=globaltotindexgroups(2,jgrp)+1 ! (total) size
7039 lgrp=jgrp
7040 END DO
7041 DO j=1,ntpgrp
7042 CALL hmpent(15,real(globaltotindexgroups(2,j),mps))
7043 END DO
7044 IF(nhistp /= 0) CALL hmprnt(15) ! print histogram
7045 CALL hmpwrt(15) ! write to his file
7046 WRITE(lunlog,*) 'LOOP1:',ntpgrp, &
7047 ' is total number NTPGRP of label/parameter groups'
7048 !print *, ' globalTotIndexGroups ', globalTotIndexGroups
7049
7050 ! translation table of length NVGB of total global indices ---------
7051 length=nvgb
7052 CALL mpalloc(globalparvartototal,length,'translation table var -> total')
7053 indab=0
7054 DO i=1,ntgb
7055 IF(globalparlabelindex(2,i) > 0) THEN
7056 indab=indab+1
7057 globalparvartototal(indab)=i
7058 END IF
7059 END DO
7060
7061 ! regularization ---------------------------------------------------
7062 CALL mpalloc(globalparpreweight,length,'pre-sigmas weights') ! presigma weights
7063 WRITE(*,112) ' Default pre-sigma =',regpre, &
7064 ' (if no individual pre-sigma defined)'
7065 WRITE(*,*) 'Pre-sigma factor is',regula
7066
7067 IF(nregul == 0) THEN
7068 WRITE(*,*) 'No regularization will be done'
7069 ELSE
7070 WRITE(*,*) 'Regularization will be done, using factor',regula
7071 END IF
7072112 FORMAT(a,e9.2,a)
7073 IF (nvgb <= 0) THEN
7074 CALL peend(22,'Aborted, no variable global parameters')
7075 stop '... no variable global parameters'
7076 ENDIF
7077
7078 DO ivgbi=1,nvgb ! IVGBI = index of variable global parameter
7079 itgbi=globalparvartototal(ivgbi) ! ITGBI = global parameter index
7080 presg=globalparpresigma(itgbi) ! get pre-sigma
7081 prewt=0.0 ! pre-weight
7082 IF(presg > 0.0) THEN
7083 prewt=1.0/presg**2 ! 1/presigma^2
7084 ELSE IF(presg == 0.0.AND.regpre > 0.0) THEN
7085 prewt=1.0/real(regpre**2,mpd) ! default 1/presigma^2
7086 END IF
7087 globalparpreweight(ivgbi)=regula*prewt ! weight = factor / presigma^2
7088 END DO
7089
7090 ! WRITE(*,*) 'GlPa_index GlPa_label array1 array6'
7091 DO i=1,ntgb
7092 itgbl=globalparlabelindex(1,i)
7093 ivgbi=globalparlabelindex(2,i)
7094 IF(ivgbi > 0) THEN
7095 ! WRITE(*,111) I,ITGBL,QM(IND1+I),QM(IND6+IVGBI)
7096 ELSE
7097 ! WRITE(*,111) I,ITGBL,QM(IND1+I)
7098 END IF
7099 END DO
7100 ! 111 FORMAT(I5,I10,F10.5,E12.4)
7101 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7102 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7103 ! To avoid INT(mpi) overflows in diagonalization
7104 IF (metsol == 2.AND.nvgb >= 46340) THEN
7105 metsol=1
7106 WRITE(*,101) 'Too many variable parameters for diagonalization, fallback is inversion'
7107 END IF
7108
7109 ! print overview over important numbers ----------------------------
7110
7111 nrecal=nrec
7112 IF(mprint /= 0) THEN
7113 WRITE(*,*) ' '
7114 WRITE(*,101) ' NREC',nrec,'number of records'
7115 IF (nrecd > 0) WRITE(*,101) ' NRECD',nrec,'number of records containing doubles'
7116 WRITE(*,101) ' NEQN',neqn,'number of equations (measurements)'
7117 WRITE(*,101) ' NEGB',negb,'number of equations with global parameters'
7118 WRITE(*,101) ' NDGB',ndgb,'number of global derivatives'
7119 IF (mcount == 0) THEN
7120 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7121 ELSE
7122 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7123 ENDIF
7124 IF(iteren > mreqenf) &
7125 WRITE(*,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7126 WRITE(*,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7127 IF (mreqpe > 1) WRITE(*,101) &
7128 'MREQPE',mreqpe,'required number of pair entries'
7129 IF (msngpe >= 1) WRITE(*,101) &
7130 'MSNGPE',msngpe,'max pair entries single prec. storage'
7131 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7132 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7133 IF(mprint > 1) THEN
7134 WRITE(*,*) ' '
7135 WRITE(*,*) 'Global parameter labels:'
7136 mqi=ntgb
7137 IF(mqi <= 100) THEN
7138 WRITE(*,*) (globalparlabelindex(2,i),i=1,mqi)
7139 ELSE
7140 WRITE(*,*) (globalparlabelindex(2,i),i=1,30)
7141 WRITE(*,*) ' ...'
7142 mqi=((mqi-20)/20)*20+1
7143 WRITE(*,*) (globalparlabelindex(2,i),i=mqi,ntgb)
7144 END IF
7145 END IF
7146 WRITE(*,*) ' '
7147 WRITE(*,*) ' '
7148 END IF
7149 WRITE(8,*) ' '
7150 WRITE(8,101) ' NREC',nrec,'number of records'
7151 IF (nrecd > 0) WRITE(8,101) ' NRECD',nrec,'number of records containing doubles'
7152 WRITE(8,101) ' NEQN',neqn,'number of equations (measurements)'
7153 WRITE(8,101) ' NEGB',negb,'number of equations with global parameters'
7154 WRITE(8,101) ' NDGB',ndgb,'number of global derivatives'
7155 IF (mcount == 0) THEN
7156 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7157 ELSE
7158 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7159 ENDIF
7160 IF(iteren > mreqenf) &
7161 WRITE(8,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7162 WRITE(8,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7163
7164 WRITE(lunlog,*) 'LOOP1: ending'
7165 WRITE(lunlog,*) ' '
7166 CALL mend
7167
7168101 FORMAT(1x,a8,' =',i14,' = ',a)
7169END SUBROUTINE loop1
7170
7178SUBROUTINE loop1i
7179 USE mpmod
7180 USE mpdalc
7181
7182 IMPLICIT NONE
7183 INTEGER(mpi) :: i
7184 INTEGER(mpi) :: ibuf
7185 INTEGER(mpi) :: ij
7186 INTEGER(mpi) :: indab
7187 INTEGER(mpi) :: ist
7188 INTEGER(mpi) :: j
7189 INTEGER(mpi) :: ja
7190 INTEGER(mpi) :: jb
7191 INTEGER(mpi) :: jsp
7192 INTEGER(mpi) :: nc31
7193 INTEGER(mpi) :: nr
7194 INTEGER(mpi) :: nlow
7195 INTEGER(mpi) :: nst
7196 INTEGER(mpi) :: nwrd
7197
7198 INTEGER(mpl) :: length
7199 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: newCounter
7200 SAVE
7201
7202 ! ...
7203 WRITE(lunlog,*) ' '
7204 WRITE(lunlog,*) 'LOOP1: iterating'
7205 WRITE(*,*) ' '
7206 WRITE(*,*) 'LOOP1: iterating'
7207
7208 length=ntgb
7209 CALL mpalloc(newcounter,length,'new entries counter')
7210 newcounter=0
7211
7212 ! define read buffer
7213 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7214 nwrd=nc31+1
7215 length=nwrd*mthrdr
7216 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7217 nwrd=nc31*10+2+ndimbuf
7218 length=nwrd*mthrdr
7219 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7220 CALL mpalloc(readbufferdatad,length,'read buffer, double')
7221 ! to read (old) float binary files
7222 length=(ndimbuf+2)*mthrdr
7223 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7224
7225 DO
7226 CALL peread(nr) ! read records
7227 CALL peprep(1) ! prepare records
7228 DO ibuf=1,numreadbuffer ! buffer for current record
7229 ist=readbufferpointer(ibuf)+1
7230 nst=readbufferdatai(readbufferpointer(ibuf))
7231 nwrd=nst-ist+1
7232 DO ! loop over measurements
7233 CALL isjajb(nst,ist,ja,jb,jsp)
7234 IF(ja == 0.AND.jb == 0) EXIT
7235 IF(ja /= 0) THEN
7236 nlow=0
7237 DO j=1,ist-jb
7238 ij=readbufferdatai(jb+j) ! index of global parameter
7239 ij=globalparlabelindex(2,ij) ! change to variable parameter
7240 IF(ij == -2) nlow=nlow+1 ! fixed by entries cut
7241 END DO
7242 IF(nlow == 0) THEN
7243 DO j=1,ist-jb
7244 ij=readbufferdatai(jb+j) ! index of global parameter
7245 newcounter(ij)=newcounter(ij)+1 ! count again
7246 END DO
7247 ENDIF
7248 END IF
7249 END DO
7250 ! end-of-event
7251 END DO
7252 IF(nr <= 0) EXIT ! end of data?
7253 END DO
7254
7255 ! release read buffer
7256 CALL mpdealloc(readbufferdataf)
7257 CALL mpdealloc(readbufferdatad)
7258 CALL mpdealloc(readbufferdatai)
7259 CALL mpdealloc(readbufferpointer)
7260
7261 indab=0
7262 DO i=1,ntgb
7263 IF(globalparlabelindex(2,i) > 0) THEN
7264 IF(newcounter(i) >= mreqenf .OR. globalparlabelcounter(i) >= iteren) THEN
7265 indab=indab+1
7266 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
7267 ELSE
7268 globalparlabelindex(2,i)=-3 ! fixed (iterated entries cut), not used in matrix (not active)
7269 END IF
7270 END IF
7271 END DO
7272 globalparheader(-6)=indab ! counted variable
7273 nvgb=indab ! nr of variable parameters
7274 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7275 CALL mpdealloc(newcounter)
7276
7277END SUBROUTINE loop1i
7278
7289
7290SUBROUTINE loop2
7291 USE mpmod
7292 USE mpdalc
7293
7294 IMPLICIT NONE
7295 REAL(mps) :: chin2
7296 REAL(mps) :: chin3
7297 REAL(mps) :: cpr
7298 REAL(mps) :: fsum
7299 REAL(mps) :: gbc
7300 REAL(mps) :: gbu
7301 INTEGER(mpi) :: i
7302 INTEGER(mpi) :: ia
7303 INTEGER(mpi) :: ib
7304 INTEGER(mpi) :: ibuf
7305 INTEGER(mpi) :: icblst
7306 INTEGER(mpi) :: icboff
7307 INTEGER(mpi) :: icgb
7308 INTEGER(mpi) :: icgrp
7309 INTEGER(mpi) :: icount
7310 INTEGER(mpi) :: iext
7311 INTEGER(mpi) :: ihis
7312 INTEGER(mpi) :: ij
7313 INTEGER(mpi) :: ij1
7314 INTEGER(mpi) :: ijn
7315 INTEGER(mpi) :: ioff
7316 INTEGER(mpi) :: ipoff
7317 INTEGER(mpi) :: iproc
7318 INTEGER(mpi) :: irecmm
7319 INTEGER(mpi) :: ist
7320 INTEGER(mpi) :: itgbi
7321 INTEGER(mpi) :: itgbij
7322 INTEGER(mpi) :: itgbik
7323 INTEGER(mpi) :: ivgbij
7324 INTEGER(mpi) :: ivgbik
7325 INTEGER(mpi) :: ivpgrp
7326 INTEGER(mpi) :: j
7327 INTEGER(mpi) :: ja
7328 INTEGER(mpi) :: jb
7329 INTEGER(mpi) :: jcgrp
7330 INTEGER(mpi) :: jext
7331 INTEGER(mpi) :: jcgb
7332 INTEGER(mpi) :: jrec
7333 INTEGER(mpi) :: jsp
7334 INTEGER(mpi) :: joff
7335 INTEGER(mpi) :: k
7336 INTEGER(mpi) :: kcgrp
7337 INTEGER(mpi) :: kfile
7338 INTEGER(mpi) :: l
7339 INTEGER(mpi) :: label
7340 INTEGER(mpi) :: labelf
7341 INTEGER(mpi) :: labell
7342 INTEGER(mpi) :: lvpgrp
7343 INTEGER(mpi) :: lu
7344 INTEGER(mpi) :: lun
7345 INTEGER(mpi) :: maeqnf
7346 INTEGER(mpi) :: nall
7347 INTEGER(mpi) :: naeqna
7348 INTEGER(mpi) :: naeqnf
7349 INTEGER(mpi) :: naeqng
7350 INTEGER(mpi) :: npdblk
7351 INTEGER(mpi) :: nc31
7352 INTEGER(mpi) :: ncachd
7353 INTEGER(mpi) :: ncachi
7354 INTEGER(mpi) :: ncachr
7355 INTEGER(mpi) :: ncon
7356 INTEGER(mpi) :: nda
7357 INTEGER(mpi) :: ndf
7358 INTEGER(mpi) :: ndfmax
7359 INTEGER(mpi) :: nfixed
7360 INTEGER(mpi) :: nggd
7361 INTEGER(mpi) :: nggi
7362 INTEGER(mpi) :: nmatmo
7363 INTEGER(mpi) :: noff
7364 INTEGER(mpi) :: npair
7365 INTEGER(mpi) :: npar
7366 INTEGER(mpi) :: nparmx
7367 INTEGER(mpi) :: nr
7368 INTEGER(mpi) :: nrece
7369 INTEGER(mpi) :: nrecf
7370 INTEGER(mpi) :: nrecmm
7371 INTEGER(mpi) :: nst
7372 INTEGER(mpi) :: nwrd
7373 INTEGER(mpi) :: inone
7374 INTEGER(mpi) :: inc
7375 REAL(mps) :: wgh
7376 REAL(mps) :: wolfc3
7377 REAL(mps) :: wrec
7378 REAL(mps) :: chindl
7379
7380 REAL(mpd)::dstat(3)
7381 REAL(mpd)::rerr
7382 INTEGER(mpl):: nblock
7383 INTEGER(mpl):: nbwrds
7384 INTEGER(mpl):: noff8
7385 INTEGER(mpl):: ndimbi
7386 INTEGER(mpl):: ndimsa(4)
7387 INTEGER(mpl):: ndgn
7388 INTEGER(mpl):: nnzero
7389 INTEGER(mpl):: matsiz(2)
7390 INTEGER(mpl):: matwords
7391 INTEGER(mpl):: mbwrds
7392 INTEGER(mpl):: length
7393 INTEGER(mpl):: rows
7394 INTEGER(mpl):: cols
7395 INTEGER(mpl), PARAMETER :: two=2
7396 INTEGER(mpi) :: maxGlobalPar = 0
7397 INTEGER(mpi) :: maxLocalPar = 0
7398 INTEGER(mpi) :: maxEquations = 0
7399
7400 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupList
7401 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupIndex
7402 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
7403 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecBlockCounts
7404
7405 INTERFACE ! needed for assumed-shape dummy arguments
7406 SUBROUTINE ndbits(npgrp,ndims,nsparr,ihst)
7407 USE mpdef
7408 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7409 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7410 INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr
7411 INTEGER(mpi), INTENT(IN) :: ihst
7412 END SUBROUTINE ndbits
7413 SUBROUTINE ckbits(npgrp,ndims)
7414 USE mpdef
7415 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7416 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7417 END SUBROUTINE ckbits
7418 SUBROUTINE spbits(npgrp,nsparr,nsparc)
7419 USE mpdef
7420 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7421 INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr
7422 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc
7423 END SUBROUTINE spbits
7424 SUBROUTINE gpbmap(ngroup,npgrp,npair)
7425 USE mpdef
7426 INTEGER(mpi), INTENT(IN) :: ngroup
7427 INTEGER(mpi), DIMENSION(:,:), INTENT(IN) :: npgrp
7428 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair
7429 END SUBROUTINE gpbmap
7430 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
7431 USE mpdef
7432 INTEGER(mpi), INTENT(IN) :: ipgrp
7433 INTEGER(mpi), INTENT(OUT) :: npair
7434 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
7435 END SUBROUTINE ggbmap
7436 SUBROUTINE pbsbits(npgrp,ibsize,nnzero,nblock,nbkrow)
7437 USE mpdef
7438 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7439 INTEGER(mpi), INTENT(IN) :: ibsize
7440 INTEGER(mpl), INTENT(OUT) :: nnzero
7441 INTEGER(mpl), INTENT(OUT) :: nblock
7442 INTEGER(mpi), DIMENSION(:),INTENT(OUT) :: nbkrow
7443 END SUBROUTINE pbsbits
7444 SUBROUTINE pblbits(npgrp,ibsize,nsparr,nsparc)
7445 USE mpdef
7446 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7447 INTEGER(mpi), INTENT(IN) :: ibsize
7448 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7449 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7450 END SUBROUTINE pblbits
7451 SUBROUTINE prbits(npgrp,nsparr)
7452 USE mpdef
7453 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7454 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparr
7455 END SUBROUTINE prbits
7456 SUBROUTINE pcbits(npgrp,nsparr,nsparc)
7457 USE mpdef
7458 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7459 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7460 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7461 END SUBROUTINE pcbits
7462 END INTERFACE
7463
7464 SAVE
7465
7466 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
7467
7468 ! ...
7469 WRITE(lunlog,*) ' '
7470 WRITE(lunlog,*) 'LOOP2: starting'
7471 CALL mstart('LOOP2')
7472
7473 ! two subarrays to get the global parameter indices, used in an event
7474 length=nvgb
7475 CALL mpalloc(globalindexusage,length,'global index')
7476 CALL mpalloc(backindexusage,length,'back index')
7477 backindexusage=0
7478 CALL mpalloc(globalindexranges,length,'global index ranges')
7479 globalindexranges=0
7480
7481 ! prepare constraints - determine number of constraints NCGB
7482 ! - sort and split into blocks
7483 ! - update globalIndexRanges
7484 CALL prpcon
7485
7486 IF (metsol == 3.AND.icelim <= 0) THEN
7487 ! decomposition: enforce elimination
7488 icelim=1
7489 WRITE(lunlog,*) ' Elimination for constraints enforced for solution by decomposition!'
7490 END IF
7491 IF (metsol == 9.AND.icelim > 0) THEN
7492 ! sparsePARDISO: enforce multipliers
7493 icelim=0
7494 WRITE(lunlog,*) ' Lagrange multipliers enforced for solution by sparsePARDISO!'
7495 END IF
7496 IF (matsto > 0.AND.icelim > 1) THEN
7497 ! decomposition: enforce elimination
7498 icelim=1
7499 WRITE(lunlog,*) ' Elimination for constraints with mpqldec enforced (LAPACK only for unpacked storage)!'
7500 END IF
7501 IF (icelim > 0) THEN ! elimination
7502 nagb=nvgb ! total number of parameters
7503 napgrp=nvpgrp ! total number of parameter groups
7504 nfgb=nvgb-ncgb ! number of fit parameters
7505 nprecond(1)=0 ! number of constraints for preconditioner
7506 nprecond(2)=nfgb ! matrix size for preconditioner
7507 nprecond(3)=0 ! number of constraint blocks for preconditioner
7508 ELSE ! Lagrange multipliers
7509 nagb=nvgb+ncgb ! total number of parameters
7510 napgrp=nvpgrp+ncgb ! total number of parameter groups
7511 nfgb=nagb ! number of fit parameters
7512 nprecond(1)=ncgb ! number of constraints for preconditioner
7513 nprecond(2)=nvgb ! matrix size for preconditioner
7514 nprecond(3)=ncblck ! number of constraint blocks for preconditioner
7515 ENDIF
7516 noff8=int(nagb,mpl)*int(nagb-1,mpl)/2
7517
7518 ! all (variable) parameter groups
7519 length=napgrp+1
7520 CALL mpalloc(globalallindexgroups,length,'all parameter groups, 1. index')
7521 globalallindexgroups=0
7522 ivpgrp=0
7523 lvpgrp=-1
7524 DO i=1,ntgb
7525 ij=globalparlabelindex(2,i)
7526 IF (ij <= 0) cycle ! variable ?
7527 IF (globalparlabelindex(4,i) /= lvpgrp) THEN
7528 ivpgrp=ivpgrp+1
7529 globalallindexgroups(ivpgrp)=ij ! first index
7530 lvpgrp=globalparlabelindex(4,i)
7531 END IF
7532 END DO
7533 ! Lagrange multipliers
7534 IF (napgrp > nvpgrp) THEN
7535 DO jcgb=1, ncgb
7536 ivpgrp=ivpgrp+1
7537 globalallindexgroups(ivpgrp)=nvgb+jcgb
7538 END DO
7539 END IF
7540 globalallindexgroups(napgrp+1)=nagb+1
7541 ! from all (variable) parameters to group
7542 length=nagb
7543 CALL mpalloc(globalallpartogroup,length,'translation table all (var) par -> group')
7544 globalallpartogroup=0
7545 DO i=1,napgrp
7546 DO j=globalallindexgroups(i),globalallindexgroups(i+1)-1
7547 globalallpartogroup(j)=i
7548 END DO
7549 END DO
7550 IF (icheck > 2) THEN
7551 print *
7552 print *, ' Variable parameter groups ', nvpgrp
7553 DO i=1,nvpgrp
7554 itgbi=globalparvartototal(globalallindexgroups(i))
7555 k=globalparlabelindex(4,itgbi) ! (total) group index
7556 print *, i,k,globalallindexgroups(i),globalallindexgroups(i+1)-globalallindexgroups(i), &
7557 globalparlabelindex(1,itgbi)
7558 END DO
7559 print *
7560 END IF
7561
7562 ! read all data files and add all variable index pairs -------------
7563
7564 IF (icheck > 1) CALL clbmap(ntpgrp+ncgrp)
7565
7566 IF(matsto == 2) THEN
7567 ! MINRES, sparse storage
7568 CALL clbits(napgrp,mreqpe,mhispe,msngpe,mextnd,ndimbi,nspc) ! get dimension for bit storage, encoding, precision info
7569 END IF
7570 IF(matsto == 3) THEN
7571 ! PARDISO, upper triangle (parameter groups) incl. rectangular part (constraints)
7572 CALL plbits(nvpgrp,nvgb,ncgb,ndimbi) ! get dimension for bit storage, global parameters and constraints
7573 END IF
7574
7575 IF (imonit /= 0) THEN
7576 length=ntgb
7577 CALL mpalloc(measindex,length,'measurement counter/index')
7578 measindex=0
7579 CALL mpalloc(measres,length,'measurement resolution')
7580 measres=0.0_mps
7581 lunmon=9
7582 CALL mvopen(lunmon,'millepede.mon')
7583 ENDIF
7584
7585 ! for checking appearance
7586 IF (icheck > 1) THEN
7587 length=5*(ntgb+ncgrp)
7588 CALL mpalloc(appearancecounter,length,'appearance statistics')
7589 appearancecounter=0
7590 length=ntgb
7591 CALL mpalloc(paircounter,length,'pair statistics')
7592 paircounter=0
7593 END IF
7594
7595 ! checking constraint goups
7596 IF (icheck > 0.AND. ncgrp > 0) THEN
7597 length=ncgrp
7598 CALL mpalloc(vecconsgroupcounts,length,'counter for constraint groups')
7599 vecconsgroupcounts=0
7600 CALL mpalloc(vecconsgrouplist,length,'constraint group list')
7601 CALL mpalloc(vecconsgroupindex,length,'constraint group index')
7602 vecconsgroupindex=0
7603 END IF
7604
7605 ! reading events===reading events===reading events===reading events=
7606 nrece =0 ! 'empty' records (no variable global parameters)
7607 nrecf =0 ! records with fixed global parameters
7608 naeqng=0 ! count number of equations (with global der.)
7609 naeqnf=0 ! count number of equations ( " , fixed)
7610 naeqna=0 ! all
7611 WRITE(lunlog,*) 'LOOP2: start event reading'
7612 ! monitoring for sparse matrix?
7613 irecmm=0
7614 IF (matsto == 2.AND.matmon /= 0) THEN
7615 nmatmo=0
7616 IF (matmon > 0) THEN
7617 nrecmm=matmon
7618 ELSE
7619 nrecmm=1
7620 END IF
7621 END IF
7622 DO k=1,3
7623 dstat(k)=0.0_mpd
7624 END DO
7625 ! define read buffer
7626 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7627 nwrd=nc31+1
7628 length=nwrd*mthrdr
7629 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7630 nwrd=nc31*10+2+ndimbuf
7631 length=nwrd*mthrdr
7632 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7633 CALL mpalloc(readbufferdatad,length,'read buffer, real')
7634 ! to read (old) float binary files
7635 length=(ndimbuf+2)*mthrdr
7636 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7637
7638 DO
7639 CALL peread(nr) ! read records
7640 CALL peprep(1) ! prepare records
7641 ioff=0
7642 DO ibuf=1,numreadbuffer ! buffer for current record
7643 jrec=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
7644 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7645 nrec=ifd(kfile)+jrec ! global record number
7646 ! Printout for DEBUG
7647 IF(nrec <= mdebug) THEN
7648 nda=0
7649 wrec =real(readbufferdatad(readbufferpointer(ibuf)-1),mps) ! weight
7650 WRITE(*,*) ' '
7651 WRITE(*,*) 'Record number ',nrec,' from file ',kfile
7652 IF (wgh /= 1.0) WRITE(*,*) ' weight ',wrec
7653 ist=readbufferpointer(ibuf)+1
7654 nst=readbufferdatai(readbufferpointer(ibuf))
7655 DO ! loop over measurements
7656 CALL isjajb(nst,ist,ja,jb,jsp)
7657 IF(ja == 0) EXIT
7658 nda=nda+1
7659 IF(nda > mdebg2) THEN
7660 IF(nda == mdebg2+1) WRITE(*,*) '... and more data'
7661 cycle
7662 END IF
7663 WRITE(*,*) ' '
7664 WRITE(*,*) nda, ' Measured value =',readbufferdatad(ja),' +- ',readbufferdatad(jb)
7665 WRITE(*,*) 'Local derivatives:'
7666 WRITE(*,107) (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
7667107 FORMAT(6(i3,g12.4))
7668 IF (jb < ist) THEN
7669 WRITE(*,*) 'Global derivatives:'
7670 WRITE(*,108) (globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
7671 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
7672108 FORMAT(3i11,g12.4)
7673 END IF
7674 IF(nda == 1) THEN
7675 WRITE(*,*) 'total_par_label __label__ var_par_index derivative'
7676 END IF
7677 END DO
7678 WRITE(*,*) ' '
7679 END IF
7680
7681 nagbn =0 ! count number of global derivatives
7682 nalcn =0 ! count number of local derivatives
7683 naeqn =0 ! count number of equations
7684 icgrp =0 ! count constraint groups
7685 maeqnf=naeqnf
7686 ist=readbufferpointer(ibuf)+1
7687 nst=readbufferdatai(readbufferpointer(ibuf))
7688 nwrd=nst-ist+1
7689 DO ! loop over measurements
7690 CALL isjajb(nst,ist,ja,jb,jsp)
7691 IF(ja == 0.AND.jb == 0) EXIT
7692 naeqn=naeqn+1
7693 naeqna=naeqna+1
7694 IF(ja /= 0) THEN
7695 IF (ist > jb) THEN
7696 naeqng=naeqng+1
7697 ! monitoring, group measurements, sum up entries and errors
7698 IF (imonit /= 0) THEN
7699 rerr =real(readbufferdatad(jb),mpd) ! the error
7700 ij=readbufferdatai(jb+1) ! index of first global parameter, used to group measurements
7701 measindex(ij)=measindex(ij)+1
7702 measres(ij)=measres(ij)+rerr
7703 END IF
7704 END IF
7705 nfixed=0
7706 DO j=1,ist-jb
7707 ij=readbufferdatai(jb+j) ! index of global parameter
7708 ! check appearance
7709 IF (icheck > 1) THEN
7710 joff = 5*(ij-1)
7711 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7712 IF (appearancecounter(joff+1) == 0) THEN
7713 appearancecounter(joff+1) = kfile
7714 appearancecounter(joff+2) = jrec ! (local) record number
7715 END IF
7716 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=appearancecounter(joff+5)+1
7717 appearancecounter(joff+3) = kfile
7718 appearancecounter(joff+4) = jrec ! (local) record number
7719 ! count pairs
7720 DO k=1,j
7721 CALL inbmap(globalparlabelindex(4,ij),globalparlabelindex(4,readbufferdatai(jb+k)))
7722 END DO
7723 jcgrp=globalparcons(ij)
7724 ! correlate constraint groups with 'other' parameter groups
7725 DO k=1,j
7726 kcgrp=globalparcons(readbufferdatai(jb+k))
7727 IF (kcgrp == jcgrp) cycle
7728 IF (jcgrp > 0) CALL inbmap(ntpgrp+jcgrp,globalparlabelindex(4,readbufferdatai(jb+k)))
7729 IF (kcgrp > 0) CALL inbmap(ntpgrp+kcgrp,globalparlabelindex(4,ij))
7730 END DO
7731 END IF
7732 ! check constraint groups
7733 IF (icheck > 0.AND.ncgrp > 0) THEN
7734 k=globalparcons(ij) ! constraint group
7735 IF (k > 0) THEN
7736 icount=naeqn
7737 IF (mcount > 0) icount=1 ! count records
7738 IF (vecconsgroupindex(k) == 0) THEN
7739 ! add to list
7740 icgrp=icgrp+1
7741 vecconsgrouplist(icgrp)=k
7742 ! check appearance
7743 IF (icheck > 1) THEN
7744 joff = 5*(ntgb+k-1)
7745 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7746 IF (appearancecounter(joff+1) == 0) THEN
7747 appearancecounter(joff+1) = kfile
7748 appearancecounter(joff+2) = jrec ! (local) record number
7749 END IF
7750 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=&
7751 appearancecounter(joff+5)+1
7752 appearancecounter(joff+3) = kfile
7753 appearancecounter(joff+4) = jrec ! (local) record number
7754 END IF
7755 END IF
7756 IF (vecconsgroupindex(k) < icount) THEN
7757 ! count
7758 vecconsgroupindex(k)=icount
7759 vecconsgroupcounts(k)=vecconsgroupcounts(k)+1
7760 END IF
7761 END IF
7762 END IF
7763
7764 ij=globalparlabelindex(2,ij) ! change to variable parameter
7765 IF(ij > 0) THEN
7766 ijn=backindexusage(ij) ! get index of index
7767 IF(ijn == 0) THEN ! not yet included
7768 nagbn=nagbn+1 ! count
7769 globalindexusage(nagbn)=ij ! store variable index
7770 backindexusage(ij)=nagbn ! store back index
7771 END IF
7772 ELSE
7773 nfixed=nfixed+1
7774 END IF
7775 END DO
7776 IF (nfixed > 0) naeqnf=naeqnf+1
7777 END IF
7778
7779 IF(ja /= 0.AND.jb /= 0) THEN
7780 DO j=1,jb-ja-1 ! local parameters
7781 ij=readbufferdatai(ja+j)
7782 nalcn=max(nalcn,ij)
7783 END DO
7784 END IF
7785 END DO
7786
7787 ! end-of-event
7788 IF (naeqnf > maeqnf) nrecf=nrecf+1
7789 irecmm=irecmm+1
7790 ! end-of-event-end-of-event-end-of-event-end-of-event-end-of-event-e
7791
7792 maxglobalpar=max(nagbn,maxglobalpar) ! maximum number of global parameters
7793 maxlocalpar=max(nalcn,maxlocalpar) ! maximum number of local parameters
7794 maxequations=max(naeqn,maxequations) ! maximum number of equations
7795
7796 ! sample statistics for caching
7797 dstat(1)=dstat(1)+real((nwrd+2)*2,mpd) ! record size
7798 dstat(2)=dstat(2)+real(nagbn+2,mpd) ! indices,
7799 dstat(3)=dstat(3)+real(nagbn*nagbn+nagbn,mpd) ! data for MUPDAT
7800
7801 ! clear constraint groups index
7802 DO k=1, icgrp
7803 vecconsgroupindex(vecconsgrouplist(k))=0
7804 END DO
7805
7806 CALL sort1k(globalindexusage,nagbn) ! sort global par.
7807
7808 IF (nagbn == 0) THEN
7809 nrece=nrece+1
7810 ELSE
7811 ! update parameter range
7812 globalindexranges(globalindexusage(1))=&
7813 max(globalindexranges(globalindexusage(1)),globalindexusage(nagbn))
7814 ENDIF
7815
7816 ! overwrite read buffer with lists of global labels
7817 ioff=ioff+1
7818 readbufferpointer(ibuf)=ioff
7819 readbufferdatai(ioff)=ioff+nagbn
7820 joff=ioff
7821 lvpgrp=-1
7822 DO i=1,nagbn ! reset global index array, store parameter groups
7823 iext=globalindexusage(i)
7824 backindexusage(iext)=0
7825 ivpgrp=globalallpartogroup(iext)
7826 !ivpgrp=iext
7827 IF (ivpgrp /= lvpgrp) THEN
7828 joff=joff+1
7829 readbufferdatai(joff)=ivpgrp
7830 lvpgrp=ivpgrp
7831 END IF
7832 END DO
7833 readbufferdatai(ioff)=joff
7834 ioff=joff
7835
7836 END DO
7837 ioff=0
7838
7839 IF (matsto == 3) THEN
7840 !$OMP PARALLEL &
7841 !$OMP DEFAULT(PRIVATE) &
7842 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
7843 iproc=0
7844 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
7845 DO ibuf=1,numreadbuffer
7846 ist=readbufferpointer(ibuf)+1
7847 nst=readbufferdatai(readbufferpointer(ibuf))
7848 DO i=ist,nst ! store all combinations
7849 iext=readbufferdatai(i) ! variable global index
7850 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct column per thread
7851 DO l=i,nst
7852 jext=readbufferdatai(l)
7853 CALL inbits(iext,jext,1) ! save space
7854 END DO
7855 !$ ENDIF
7856 END DO
7857 END DO
7858 !$OMP END PARALLEL
7859 END IF
7860 IF (matsto == 2) THEN
7861 !$OMP PARALLEL &
7862 !$OMP DEFAULT(PRIVATE) &
7863 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
7864 iproc=0
7865 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
7866 DO ibuf=1,numreadbuffer
7867 ist=readbufferpointer(ibuf)+1
7868 nst=readbufferdatai(readbufferpointer(ibuf))
7869 DO i=ist,nst ! store all combinations
7870 iext=readbufferdatai(i) ! variable global index
7871 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct rows per thread
7872 DO l=ist,i
7873 jext=readbufferdatai(l)
7874 CALL inbits(iext,jext,1) ! save space
7875 END DO
7876 !$ ENDIF
7877 END DO
7878 END DO
7879 !$OMP END PARALLEL
7880 ! monitoring
7881 IF (matmon /= 0.AND. &
7882 (irecmm >= nrecmm.OR.irecmm == mxrec)) THEN
7883 IF (nmatmo == 0) THEN
7884 WRITE(*,*)
7885 WRITE(*,*) 'Monitoring of sparse matrix construction'
7886 WRITE(*,*) ' records ........ off-diagonal elements ', &
7887 '....... compression memory'
7888 WRITE(*,*) ' non-zero used(double) used', &
7889 '(float) [%] [GB]'
7890 END IF
7891 nmatmo=nmatmo+1
7892 CALL ckbits(globalallindexgroups,ndimsa)
7893 gbc=1.0e-9*real((mpi*ndimsa(2)+mpd*ndimsa(3)+mps*ndimsa(4))/mpi*(bit_size(1_mpi)/8),mps) ! GB compressed
7894 gbu=1.0e-9*real(((mpi+mpd)*(ndimsa(3)+ndimsa(4)))/mpi*(bit_size(1_mpi)/8),mps) ! GB uncompressed
7895 cpr=100.0*gbc/gbu
7896 WRITE(*,1177) irecmm,ndimsa(1),ndimsa(3),ndimsa(4),cpr,gbc
78971177 FORMAT(i9,3i13,f10.2,f11.6)
7898 DO WHILE(irecmm >= nrecmm)
7899 IF (matmon > 0) THEN
7900 nrecmm=nrecmm+matmon
7901 ELSE
7902 nrecmm=nrecmm*2
7903 END IF
7904 END DO
7905 END IF
7906
7907 END IF
7908
7909 IF (nr <= 0) EXIT ! next block of events ?
7910 END DO
7911 ! release read buffer
7912 CALL mpdealloc(readbufferdataf)
7913 CALL mpdealloc(readbufferdatad)
7914 CALL mpdealloc(readbufferdatai)
7915 CALL mpdealloc(readbufferpointer)
7916
7917 WRITE(lunlog,*) 'LOOP2: event reading ended - end of data'
7918 DO k=1,3
7919 dstat(k)=dstat(k)/real(nrec,mpd)
7920 END DO
7921 ! end=of=data=end=of=data=end=of=data=end=of=data=end=of=data=end=of
7922
7923 IF (icheck > 0.AND. ncgrp > 0) THEN
7924 CALL mpdealloc(vecconsgroupindex)
7925 CALL mpdealloc(vecconsgrouplist)
7926 END IF
7927
7928 IF (icheck > 1) THEN
7929 CALL gpbmap(ntpgrp,globaltotindexgroups,paircounter)
7930 END IF
7931 IF (icheck > 3) THEN
7932 length=ntpgrp+ncgrp
7933 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
7934 print *
7935 print *, ' Total parameter groups pairs', ntpgrp
7936 DO i=1,ntpgrp
7937 itgbi=globaltotindexgroups(1,i)
7938 CALL ggbmap(i,npair,vecpairedpargroups)
7939 k=globalparlabelindex(4,itgbi) ! (total) group index
7940 print *, i, itgbi, globalparlabelindex(1,itgbi), npair, ':', vecpairedpargroups(:npair)
7941 END DO
7942 print *
7943 END IF
7944
7945 ! check constraints
7946 IF(matsto == 2) THEN
7947
7948 ! constraints and index pairs with Lagrange multiplier
7949 inc=max(mreqpe, msngpe+1) ! keep constraints in double precision
7950
7951 ! loop over (sorted) constraints
7952 DO jcgb=1,ncgb
7953 icgb=matconssort(3,jcgb) ! unsorted constraint index
7954 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
7955 label=listconstraints(i)%label
7956 itgbi=inone(label)
7957 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
7958 IF(ij > 0 .AND. nagb > nvgb) THEN
7959 CALL inbits(globalallpartogroup(nvgb+jcgb),globalallpartogroup(ij),inc)
7960 END IF
7961 END DO
7962 END DO
7963 END IF
7964 IF(matsto == 3) THEN
7965 ! loop over (sorted) constraints
7966 DO jcgb=1,ncgb
7967 icgb=matconssort(3,jcgb) ! unsorted constraint index
7968 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
7969 label=listconstraints(i)%label
7970 itgbi=inone(label)
7971 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
7972 IF(ij > 0.AND.listconstraints(i)%value /= 0.0_mpd) THEN
7973 ! non-zero coefficient
7974 CALL irbits(ij,jcgb)
7975 END IF
7976 END DO
7977 END DO
7978 END IF
7979
7980 ! check measurements
7981 IF(matsto == 2 .OR. matsto == 3) THEN
7982 ! measurements - determine index-pairs
7983
7984 i=1
7985 DO WHILE (i <= lenmeasurements)
7986 i=i+2
7987 ! loop over label/factor pairs
7988 ia=i
7989 DO
7990 i=i+1
7991 IF(i > lenmeasurements) EXIT
7992 IF(listmeasurements(i)%label < 0) EXIT
7993 END DO
7994 ib=i-1
7995
7996 DO j=ia,ib
7997 itgbij=inone(listmeasurements(j)%label) ! total parameter index
7998 ! first index
7999 ivgbij=0
8000 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8001 DO k=ia,j
8002 itgbik=inone(listmeasurements(k)%label) ! total parameter index
8003 ! second index
8004 ivgbik=0
8005 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
8006 IF(ivgbij > 0.AND.ivgbik > 0) THEN
8007 CALL inbits(globalallpartogroup(ivgbij),globalallpartogroup(ivgbik),mreqpe)
8008 IF (mprint > 1) WRITE(*,*) 'add index pair ',ivgbij,ivgbik
8009 END IF
8010 END DO
8011 END DO
8012
8013 END DO
8014 ELSE
8015 ! more checks for block diagonal structure
8016 ! loop over measurements
8017 i=1
8018 DO WHILE (i <= lenmeasurements)
8019 i=i+2
8020 ! loop over label/factor pairs
8021 ia=i
8022 DO
8023 i=i+1
8024 IF(i > lenmeasurements) EXIT
8025 IF(listmeasurements(i)%label < 0) EXIT
8026 END DO
8027 ib=i-1
8028 ij1=nvgb
8029 ijn=1
8030 DO j=ia,ib
8031 itgbij=inone(listmeasurements(j)%label) ! total parameter index
8032 ! first index
8033 ij=0
8034 IF(itgbij /= 0) ij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8035 IF (ij > 0) THEN
8036 ij1=min(ij1,ij)
8037 ijn=max(ijn,ij)
8038 END IF
8039 END DO
8040 globalindexranges(ij1)=max(globalindexranges(ij1),ijn)
8041 END DO
8042
8043 END IF
8044
8045 nummeas=0 ! number of measurement groups
8046 IF (imonit /= 0) THEN
8047 DO i=1,ntgb
8048 IF (measindex(i) > 0) THEN
8049 nummeas=nummeas+1
8050 measres(i) = measres(i)/real(measindex(i),mpd)
8051 measindex(i) = nummeas
8052 END IF
8053 END DO
8054 length=nummeas*mthrd*measbins
8055 CALL mpalloc(meashists,length,'measurement counter')
8056 END IF
8057
8058 ! check for block diagonal structure, count blocks
8059 npblck=0
8060 l=0
8061 DO i=1,nvgb
8062 IF (i > l) npblck=npblck+1
8063 l=max(l,globalindexranges(i))
8064 globalindexranges(i)=npblck ! block number
8065 END DO
8066
8067 length=npblck+1; rows=2
8068 ! parameter blocks
8069 CALL mpalloc(matparblockoffsets,rows,length,'global parameter blocks (I)')
8070 matparblockoffsets=0
8071 CALL mpalloc(vecparblockconoffsets,length,'global parameter blocks (I)')
8072 vecparblockconoffsets=0
8073 ! fill matParBlocks
8074 l=0
8075 DO i=1,nvgb
8076 IF (globalindexranges(i) > l) THEN
8077 l=globalindexranges(i) ! block number
8078 matparblockoffsets(1,l)=i-1 ! block offset
8079 END IF
8080 END DO
8081 matparblockoffsets(1,npblck+1)=nvgb
8082 nparmx=0
8083 DO i=1,npblck
8084 rows=matparblockoffsets(1,i+1)-matparblockoffsets(1,i)
8085 nparmx=max(nparmx,int(rows,mpi))
8086 END DO
8087
8088 ! connect constraint blocks
8089 DO i=1,ncblck
8090 ia=matconsblocks(2,i) ! first parameter in constraint block
8091 IF (ia > matconsblocks(3,i)) cycle
8092 ib=globalindexranges(ia) ! parameter block number
8093 matparblockoffsets(2,ib+1)=i
8094 END DO
8095
8096 ! use diagonal block matrix storage?
8097 IF (npblck > 1) THEN
8098 IF (icheck > 0) THEN
8099 WRITE(*,*)
8100 DO i=1,npblck
8101 ia=matparblockoffsets(1,i)
8102 ib=matparblockoffsets(1,i+1)
8103 ja=matparblockoffsets(2,i)
8104 jb=matparblockoffsets(2,i+1)
8105 labelf=globalparlabelindex(1,globalparvartototal(ia+1))
8106 labell=globalparlabelindex(1,globalparvartototal(ib))
8107 WRITE(*,*) ' Parameter block', i, ib-ia, jb-ja, labelf, labell
8108 ENDDO
8109 ENDIF
8110 WRITE(lunlog,*)
8111 WRITE(lunlog,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8112 WRITE(*,*)
8113 WRITE(*,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8114 IF ((metsol == 1.OR.metsol == 3.OR.metsol>=7).AND.nagb == nvgb) THEN
8115 WRITE(*,*) 'Using block diagonal storage mode'
8116 ELSE
8117 ! keep single block = full matrix
8118 DO i=1,2
8119 matparblockoffsets(i,2)=matparblockoffsets(i,npblck+1)
8120 END DO
8121 npblck=1
8122 DO i=1,nvgb
8123 globalindexranges(i)=1
8124 END DO
8125 END IF
8126 END IF
8127
8128 ! print numbers ----------------------------------------------------
8129
8130 IF (nagb >= 65536) THEN
8131 noff=int(noff8/1000,mpi)
8132 ELSE
8133 noff=int(noff8,mpi)
8134 END IF
8135 ndgn=0
8136 matwords=0
8137 IF(matsto == 2) THEN
8138 ihis=0
8139 IF (mhispe > 0) THEN
8140 ihis=15
8141 CALL hmpdef(ihis,0.0,real(mhispe,mps), 'NDBITS: #off-diagonal elements')
8142 END IF
8143 length=(napgrp+1)*nspc
8144 CALL mpalloc(sparsematrixoffsets,two,length, 'sparse matrix row offsets')
8145 CALL ndbits(globalallindexgroups,ndimsa,sparsematrixoffsets,ihis)
8146 ndgn=ndimsa(3)+ndimsa(4) ! actual number of off-diagonal elements
8147 matwords=ndimsa(2)+length*4 ! size of sparsity structure
8148
8149 IF (mhispe > 0) THEN
8150 IF (nhistp /= 0) CALL hmprnt(ihis)
8151 CALL hmpwrt(ihis)
8152 END IF
8153 END IF
8154 IF (matsto == 3) THEN
8155 length=nagb+1
8156 CALL mpalloc(csr3rowoffsets,length, 'sparse matrix row offsets (CSR3)')
8157 IF (mpdbsz > 1) THEN
8158 ! BSR3, check (for optimal) block size
8159 mbwrds=0
8160 DO i=1,mpdbsz
8161 npdblk=(nagb-1)/ipdbsz(i)+1
8162 length=int(npdblk,mpl)
8163 CALL mpalloc(vecblockcounts,length, 'sparse matrix row offsets (CSR3)')
8164 CALL pbsbits(globalallindexgroups,ipdbsz(i),nnzero,nblock,vecblockcounts)
8165 nbwrds=2*int(nblock,mpl)*int(ipdbsz(i)*ipdbsz(i)+1,mpl) ! number of words needed
8166 IF ((i == 1).OR.(nbwrds < mbwrds)) THEN
8167 matbsz=ipdbsz(i)
8168 mbwrds=nbwrds
8169 csr3rowoffsets(1)=1
8170 DO k=1,npdblk
8171 csr3rowoffsets(k+1)=csr3rowoffsets(k)+vecblockcounts(k)
8172 END DO
8173 END IF
8174 CALL mpdealloc(vecblockcounts)
8175 END DO
8176 ELSE
8177 ! CSR3
8178 CALL prbits(globalallindexgroups,csr3rowoffsets)
8179 !csr3RowOffsets(nvgb+2:)=csr3RowOffsets(nvgb+1) ! Lagrange multipliers (empty)
8180 END IF
8181 END IF
8182
8183 nagbn=maxglobalpar ! max number of global parameters in one event
8184 nalcn=maxlocalpar ! max number of local parameters in one event
8185 naeqn=maxequations ! max number of equations in one event
8186 CALL mpdealloc(globalindexusage)
8187 CALL mpdealloc(backindexusage)
8188 ! matrices for event matrices
8189 ! split up cache
8190 IF (fcache(2) == 0.0) THEN ! from data (DSTAT)
8191 fcache(1)=real(dstat(1),mps)*fcache(1) ! leave some part free for fluctuations
8192 fcache(2)=real(dstat(2),mps)
8193 fcache(3)=real(dstat(3),mps)
8194 END IF
8195 fsum=fcache(1)+fcache(2)+fcache(3)
8196 DO k=1,3
8197 fcache(k)=fcache(k)/fsum
8198 END DO
8199 ncachr=nint(real(ncache,mps)*fcache(1),mpi) ! read cache
8200 ! define read buffer
8201 nc31=ncachr/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
8202 nwrd=nc31+1
8203 length=nwrd*mthrdr
8204 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
8205 nwrd=nc31*10+2+ndimbuf
8206 length=nwrd*mthrdr
8207 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
8208 CALL mpalloc(readbufferdatad,length,'read buffer, real')
8209 ! to read (old) float binary files
8210 length=(ndimbuf+2)*mthrdr
8211 CALL mpalloc(readbufferdataf,length,'read buffer, float')
8212
8213 ncachi=nint(real(ncache,mps)*fcache(2),mpi) ! index cache
8214 ncachd=ncache-ncachr-ncachi ! data cache
8215 nggd=(nagbn*nagbn+nagbn)/2+ncachd/(2*mthrd) ! number of double
8216 nggi=2+nagbn+ncachi/mthrd ! number of ints
8217 length=nagbn*mthrd
8218 CALL mpalloc(globalindexusage,length, 'global parameters (dim =max/event)')
8219 length=nvgb*mthrd
8220 CALL mpalloc(backindexusage,length,'global variable-index array')
8221 backindexusage=0
8222 length=nagbn*nalcn
8223 CALL mpalloc(localglobalmatrix,length,'local/global matrix, content')
8224 CALL mpalloc(localglobalmap,length,'local/global matrix, map (counts)')
8225 length=2*nagbn*nalcn+nagbn+nalcn+1
8226 CALL mpalloc(localglobalstructure,length,'local/global matrix, (sparsity) structure')
8227 length=nggd*mthrd
8228 CALL mpalloc(writebufferupdates,length,'symmetric update matrices')
8229 writebufferheader(-1)=nggd ! number of words per thread
8230 writebufferheader(-2)=(nagbn*nagbn+nagbn)/2 ! min free (double) words
8231 length=nggi*mthrd
8232 CALL mpalloc(writebufferindices,length,'symmetric update matrix indices')
8233 rows=9; cols=mthrd
8234 CALL mpalloc(writebufferinfo,rows,cols,'write buffer status (I)')
8235 rows=2; cols=mthrd
8236 CALL mpalloc(writebufferdata,rows,cols,'write buffer status (F)')
8237 writebufferheader(1)=nggi ! number of words per thread
8238 writebufferheader(2)=nagbn+3 ! min free words
8239
8240 ! print all relevant dimension parameters
8241
8242 DO lu=6,8,2 ! unit 6 and 8
8243
8244 WRITE(lu,*) ' '
8245 WRITE(lu,101) 'NTGB',ntgb,'total number of parameters'
8246 WRITE(lu,102) '(all parameters, appearing in binary files)'
8247 WRITE(lu,101) 'NVGB',nvgb,'number of variable parameters'
8248 WRITE(lu,102) '(appearing in fit matrix/vectors)'
8249 WRITE(lu,101) 'NAGB',nagb,'number of all parameters'
8250 WRITE(lu,102) '(including Lagrange multiplier or reduced)'
8251 WRITE(lu,101) 'NTPGRP',ntpgrp,'total number of parameter groups'
8252 WRITE(lu,101) 'NVPGRP',nvpgrp,'number of variable parameter groups'
8253 WRITE(lu,101) 'NFGB',nfgb,'number of fit parameters'
8254 IF(metsol >= 4.AND. metsol <7) THEN ! band matrix as MINRES preconditioner
8255 WRITE(lu,101) 'MBANDW',mbandw,'band width of preconditioner matrix'
8256 WRITE(lu,102) '(if <0, no preconditioner matrix)'
8257 END IF
8258 IF (nagb >= 65536) THEN
8259 WRITE(lu,101) 'NOFF/K',noff,'max number of off-diagonal elements'
8260 ELSE
8261 WRITE(lu,101) 'NOFF',noff,'max number of off-diagonal elements'
8262 END IF
8263 IF(ndgn /= 0) THEN
8264 IF (nagb >= 65536) THEN
8265 WRITE(lu,101) 'NDGN/K',ndgn/1000,'actual number of off-diagonal elements'
8266 ELSE
8267 WRITE(lu,101) 'NDGN',ndgn,'actual number of off-diagonal elements'
8268 ENDIF
8269 ENDIF
8270 WRITE(lu,101) 'NCGB',ncgb,'number of constraints'
8271 WRITE(lu,101) 'NAGBN',nagbn,'max number of global parameters in an event'
8272 WRITE(lu,101) 'NALCN',nalcn,'max number of local parameters in an event'
8273 WRITE(lu,101) 'NAEQN',naeqn,'max number of equations in an event'
8274 IF (mprint > 1) THEN
8275 WRITE(lu,101) 'NAEQNA',naeqna,'number of equations'
8276 WRITE(lu,101) 'NAEQNG',naeqng, &
8277 'number of equations with global parameters'
8278 WRITE(lu,101) 'NAEQNF',naeqnf, &
8279 'number of equations with fixed global parameters'
8280 WRITE(lu,101) 'NRECF',nrecf, &
8281 'number of records with fixed global parameters'
8282 END IF
8283 IF (nrece > 0) THEN
8284 WRITE(lu,101) 'NRECE',nrece, &
8285 'number of records without variable parameters'
8286 END IF
8287 IF (ncache > 0) THEN
8288 WRITE(lu,101) 'NCACHE',ncache,'number of words for caching'
8289 WRITE(lu,111) (fcache(k)*100.0,k=1,3)
8290111 FORMAT(22x,'cache splitting ',3(f6.1,' %'))
8291 END IF
8292 WRITE(lu,*) ' '
8293
8294 WRITE(lu,*) ' '
8295 WRITE(lu,*) 'Solution method and matrix-storage mode:'
8296 IF(metsol == 1) THEN
8297 WRITE(lu,*) ' METSOL = 1: matrix inversion'
8298 ELSE IF(metsol == 2) THEN
8299 WRITE(lu,*) ' METSOL = 2: diagonalization'
8300 ELSE IF(metsol == 3) THEN
8301 WRITE(lu,*) ' METSOL = 3: decomposition'
8302 ELSE IF(metsol == 4) THEN
8303 WRITE(lu,*) ' METSOL = 4: MINRES (rtol', mrestl,')'
8304 ELSE IF(metsol == 5) THEN
8305 WRITE(lu,*) ' METSOL = 5: MINRES-QLP (rtol', mrestl,')'
8306 ELSE IF(metsol == 6) THEN
8307 WRITE(lu,*) ' METSOL = 6: GMRES'
8308#ifdef LAPACK64
8309 ELSE IF(metsol == 7) THEN
8310 WRITE(lu,*) ' METSOL = 7: LAPACK factorization'
8311 ELSE IF(metsol == 8) THEN
8312 WRITE(lu,*) ' METSOL = 8: LAPACK factorization'
8313#ifdef PARDISO
8314 ELSE IF(metsol == 9) THEN
8315 WRITE(lu,*) ' METSOL = 9: Intel oneMKL PARDISO'
8316#endif
8317#endif
8318 END IF
8319 WRITE(lu,*) ' with',mitera,' iterations'
8320 IF(matsto == 0) THEN
8321 WRITE(lu,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
8322 ELSE IF(matsto == 1) THEN
8323 WRITE(lu,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
8324 ELSE IF(matsto == 2) THEN
8325 WRITE(lu,*) ' MATSTO = 2: sparse matrix (custom)'
8326 ELSE IF(matsto == 3) THEN
8327 IF (matbsz < 2) THEN
8328 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
8329 ELSE
8330 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
8331 WRITE(lu,*) ' block size', matbsz
8332 END IF
8333 END IF
8334 IF(npblck > 1) THEN
8335 WRITE(lu,*) ' block diagonal with', npblck, ' blocks'
8336 END IF
8337 IF(mextnd>0) WRITE(lu,*) ' with extended storage'
8338 IF(dflim /= 0.0) THEN
8339 WRITE(lu,103) 'Convergence assumed, if expected dF <',dflim
8340 END IF
8341 IF(ncgb > 0) THEN
8342 IF(nfgb < nvgb) THEN
8343 IF (icelim > 1) THEN
8344 WRITE(lu,*) 'Constraints handled by elimination with LAPACK'
8345 ELSE
8346 WRITE(lu,*) 'Constraints handled by elimination'
8347 END IF
8348 ELSE
8349 WRITE(lu,*) 'Constraints handled by Lagrange multipliers'
8350 ENDIF
8351 END IF
8352
8353 END DO ! print loop
8354
8355 IF(nalcn == 0) THEN
8356 CALL peend(28,'Aborted, no local parameters')
8357 stop 'LOOP2: stopping due to missing local parameters'
8358 END IF
8359
8360 ! Wolfe conditions
8361
8362 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8363 IF(wolfc1 == 0.0) wolfc1=1.0e-4
8364 IF(wolfc2 == 0.0) wolfc2=0.9
8365 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8366 IF(wolfc1 <= 0.0) wolfc1=1.0e-4
8367 IF(wolfc2 >= 1.0) wolfc2=0.9
8368 IF(wolfc1 > wolfc2) THEN ! exchange
8369 wolfc3=wolfc1
8370 wolfc1=wolfc2
8371 wolfc2=wolfc3
8372 ELSE
8373 wolfc1=1.0e-4
8374 wolfc2=0.9
8375 END IF
8376 WRITE(*,105) wolfc1,wolfc2
8377 WRITE(lun,105) wolfc1,wolfc2
8378105 FORMAT(' Constants C1, C2 for Wolfe conditions:',g12.4,', ',g12.4)
8379
8380 ! prepare matrix and gradient storage ------------------------------
838132 matsiz=0 ! number of words for double, single precision storage
8382 IF (matsto == 3) THEN ! sparse matrix (CSR3, BSR3)
8383 npdblk=(nagb-1)/matbsz+1 ! number of row blocks
8384 length=csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
8385 matsiz(1)=length*int(matbsz*matbsz,mpl)
8386 matwords=(length+nagb+1)*2 ! size of sparsity structure
8387 CALL mpalloc(csr3columnlist,length,'sparse matrix column list (CSR3)')
8388 IF (matbsz > 1) THEN
8389 CALL pblbits(globalallindexgroups,matbsz,csr3rowoffsets,csr3columnlist) ! BSR3
8390 ELSE
8391 CALL pcbits(globalallindexgroups,csr3rowoffsets,csr3columnlist) ! CSR3
8392 END IF
8393 ELSE IF (matsto == 2) THEN ! sparse matrix (custom)
8394 matsiz(1)=ndimsa(3)+nagb
8395 matsiz(2)=ndimsa(4)
8396 CALL mpalloc(sparsematrixcolumns,ndimsa(2),'sparse matrix column list')
8397 CALL spbits(globalallindexgroups,sparsematrixoffsets,sparsematrixcolumns)
8398 CALL anasps ! analyze sparsity structure
8399 ELSE ! full or unpacked matrix, optional block diagonal
8400 length=nagb
8401 CALL mpalloc(globalrowoffsets,length,'global row offsets (full or unpacked (block) storage)')
8402 ! loop over blocks (multiple blocks only with elimination !)
8403 vecparblockconoffsets(1)=0
8404 DO i=1,npblck
8405 ipoff=matparblockoffsets(1,i)
8406 icboff=matparblockoffsets(2,i) ! constraint block offset
8407 icblst=matparblockoffsets(2,i+1) ! constraint block offset
8408 npar=matparblockoffsets(1,i+1)-ipoff ! size of block (number of parameters)
8409 IF (icblst > icboff) THEN
8410 ncon=matconsblocks(1,icblst+1)-matconsblocks(1,icboff+1) ! number of constraints in (parameter) block
8411 ELSE
8412 ncon=0
8413 ENDIF
8414 vecparblockconoffsets(i+1)=vecparblockconoffsets(i)+ncon
8415 nall = npar; IF (icelim <= 0) nall=npar+ncon ! add Lagrange multipliers
8416 DO k=1,nall
8417 globalrowoffsets(ipoff+k)=matsiz(1)-ipoff
8418 IF (matsto == 1) THEN
8419 matsiz(1)=matsiz(1)+k ! full ('triangular')
8420 ELSE
8421 matsiz(1)=matsiz(1)+nall ! unpacked ('quadratic')
8422 END IF
8423 END DO
8424 END DO
8425 END IF
8426 matwords=matwords+matsiz(1)*2+matsiz(2) ! #words for matrix storage
8427
8428 CALL feasma ! prepare constraint matrices
8429
8430 IF (icheck <= 0) CALL vmprep(matsiz) ! prepare matrix and gradient storage
8431 WRITE(*,*) ' '
8432 IF (matwords < 250000) THEN
8433 WRITE(*,*) 'Size of global matrix: < 1 MB'
8434 ELSE
8435 WRITE(*,*) 'Size of global matrix:',int(real(matwords,mps)*4.0e-6,mpi),' MB'
8436 ENDIF
8437 ! print chi^2 cut tables
8438
8439 ndfmax=naeqn-1
8440 WRITE(lunlog,*) ' '
8441 WRITE(lunlog,*) ' Cut values of Chi^2/Ndf and Chi2,'
8442 WRITE(lunlog,*) ' corresponding to 2 and 3 standard deviations'
8443 WRITE(lunlog,*) ' Ndf Chi^2/Ndf(2) Chi^2(2) ', &
8444 ' Chi^2/Ndf(3) Chi^2(3)'
8445 ndf=0
8446 DO
8447 IF(ndf > naeqn) EXIT
8448 IF(ndf < 10) THEN
8449 ndf=ndf+1
8450 ELSE IF(ndf < 20) THEN
8451 ndf=ndf+2
8452 ELSE IF(ndf < 100) THEN
8453 ndf=ndf+5
8454 ELSE IF(ndf < 200) THEN
8455 ndf=ndf+10
8456 ELSE
8457 EXIT
8458 END IF
8459 chin2=chindl(2,ndf)
8460 chin3=chindl(3,ndf)
8461 WRITE(lunlog,106) ndf,chin2,chin2*real(ndf,mps),chin3, chin3*real(ndf,mps)
8462 END DO
8463
8464 WRITE(lunlog,*) 'LOOP2: ending'
8465 WRITE(lunlog,*) ' '
8466 ! warnings from check input mode
8467 IF (icheck > 0) THEN
8468 IF (ncgbe /= 0) THEN
8469 WRITE(*,199) ' '
8470 WRITE(*,199) ' '
8471 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8472 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8473 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8474 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8475 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8476 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8477 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8478 WRITE(*,199) ' '
8479 WRITE(*,*) ' Number of empty constraints =',abs(ncgbe), ', should be 0'
8480 WRITE(*,*) ' => please check constraint definition, mille data'
8481 WRITE(*,199) ' '
8482 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8483 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8484 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8485 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8486 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8487 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8488 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8489 WRITE(*,199) ' '
8490 END IF
8491 END IF
8492 CALL mend
8493101 FORMAT(1x,a8,' =',i14,' = ',a)
8494102 FORMAT(22x,a)
8495103 FORMAT(1x,a,g12.4)
8496106 FORMAT(i6,2(3x,f9.3,f12.1,3x))
8497199 FORMAT(7x,a)
8498END SUBROUTINE loop2
8499
8504SUBROUTINE monres
8505 USE mpmod
8506 USE mpdalc
8507
8508 IMPLICIT NONE
8509 INTEGER(mpi) :: i
8510 INTEGER(mpi) :: ij
8511 INTEGER(mpi) :: imed
8512 INTEGER(mpi) :: j
8513 INTEGER(mpi) :: k
8514 INTEGER(mpi) :: nent
8515 INTEGER(mpi), DIMENSION(measBins) :: isuml ! location
8516 INTEGER(mpi), DIMENSION(measBins) :: isums ! scale
8517 REAL(mps) :: amed
8518 REAL(mps) :: amad
8519
8520 INTEGER(mpl) :: ioff
8521 LOGICAL :: lfirst
8522 SAVE
8523 DATA lfirst /.true./
8524
8525 ! combine data from threads
8526 ioff=0
8527 DO i=2,mthrd
8528 ioff=ioff+measbins*nummeas
8529 DO j=1,measbins*nummeas
8530 meashists(j)=meashists(j)+meashists(ioff+j)
8531 END DO
8532 END DO
8533
8534 IF (lfirst) THEN
8535 IF (imonmd == 0) THEN
8536 WRITE(lunmon,'(A)') '*** Normalized residuals grouped by first global label (per local fit cycle) ***'
8537 ELSE
8538 WRITE(lunmon,'(A)') '*** Pulls grouped by first global label (per local fit cycle) ***'
8539 ENDIF
8540 WRITE(lunmon,'(A)') '! LFC Label Entries Median RMS(MAD) <error>'
8541 lfirst=.false.
8542 END IF
8543
8544 !$POMP INST BEGIN(monres)
8545 ! analyze histograms
8546 ioff=0
8547 DO i=1,ntgb
8548 IF (measindex(i) > 0) THEN
8549 isuml=0
8550 ! sum up content
8551 isuml(1)=meashists(ioff+1)
8552 DO j=2,measbins
8553 isuml(j)=isuml(j-1)+meashists(ioff+j)
8554 END DO
8555 nent=isuml(measbins)
8556 IF (nent > 0) THEN
8557 ! get median (for location)
8558 DO j=2,measbins
8559 IF (2*isuml(j) > nent) EXIT
8560 END DO
8561 imed=j
8562 amed=real(j,mps)
8563 IF (isuml(j) > isuml(j-1)) amed=amed+real(nent-2*isuml(j-1),mps)/real(2*isuml(j)-2*isuml(j-1),mps)
8564 amed=real(measbinsize,mps)*(amed-real(measbins/2,mps))
8565 ! sum up differences
8566 isums = 0
8567 DO j=imed,measbins
8568 k=j-imed+1
8569 isums(k)=isums(k)+meashists(ioff+j)
8570 END DO
8571 DO j=imed-1,1,-1
8572 k=imed-j
8573 isums(k)=isums(k)+meashists(ioff+j)
8574 END DO
8575 DO j=2, measbins
8576 isums(j)=isums(j)+isums(j-1)
8577 END DO
8578 ! get median (for scale)
8579 DO j=2,measbins
8580 IF (2*isums(j) > nent) EXIT
8581 END DO
8582 amad=real(j-1,mps)
8583 IF (isums(j) > isums(j-1)) amad=amad+real(nent-2*isums(j-1),mps)/real(2*isums(j)-2*isums(j-1),mps)
8584 amad=real(measbinsize,mps)*amad
8585 ELSE
8586 amed=0.0
8587 amad=0.0
8588 END IF
8589 ij=globalparlabelindex(1,i)
8590 WRITE(lunmon,110) nloopn, ij, nent, amed, amad*1.4826, real(measres(i),mps)
8591 !
8592 ioff=ioff+measbins
8593 END IF
8594 END DO
8595 !$POMP INST END(monres)
8596
8597110 FORMAT(i5,2i10,3g14.5)
8598END SUBROUTINE monres
8599
8600
8604
8605SUBROUTINE vmprep(msize)
8606 USE mpmod
8607 USE mpdalc
8608
8609 IMPLICIT NONE
8610 INTEGER(mpi) :: i
8611 INTEGER(mpi) :: ib
8612 INTEGER(mpi) :: ioff
8613 INTEGER(mpi) :: ipar0
8614 INTEGER(mpi) :: ncon
8615 INTEGER(mpi) :: npar
8616 INTEGER(mpi) :: nextra
8617#ifdef LAPACK64
8618 INTEGER :: nbopt, nboptx, ILAENV
8619#endif
8620 !
8621 INTEGER(mpl), INTENT(IN) :: msize(2)
8622
8623 INTEGER(mpl) :: length
8624 INTEGER(mpl) :: nwrdpc
8625 INTEGER(mpl), PARAMETER :: three = 3
8626
8627 SAVE
8628 ! ...
8629 ! Vector/matrix storage
8630 length=nagb*mthrd
8631 CALL mpalloc(globalvector,length,'rhs vector') ! double precision vector
8632 CALL mpalloc(globalcounter,length,'rhs counter') ! integer vector
8633 lenglobalvec=nagb
8634 length=naeqn*mthrd
8635 CALL mpalloc(localcorrections,length,'residual vector of one record')
8636 CALL mpalloc(localequations,three,length,'mesurements indices (ISJAJB) of one record')
8637 length=nalcn*nalcn
8638 CALL mpalloc(aux,length,' local fit scratch array: aux')
8639 CALL mpalloc(vbnd,length,' local fit scratch array: vbnd')
8640 CALL mpalloc(vbdr,length,' local fit scratch array: vbdr')
8641 length=((nalcn+1)*nalcn)/2
8642 CALL mpalloc(clmat,length,' local fit matrix: clmat')
8643 CALL mpalloc(vbk,length,' local fit scratch array: vbk')
8644 length=nalcn
8645 CALL mpalloc(blvec,length,' local fit vector: blvec')
8646 CALL mpalloc(vzru,length,' local fit scratch array: vzru')
8647 CALL mpalloc(scdiag,length,' local fit scratch array: scdiag')
8648 CALL mpalloc(scflag,length,' local fit scratch array: scflag')
8649 CALL mpalloc(ibandh,2*length,' local fit band width hist.: ibandh')
8650
8651 CALL mpalloc(globalmatd,msize(1),'global matrix (D)' )
8652 CALL mpalloc(globalmatf,msize(2),'global matrix (F)')
8653
8654 mszpcc=0
8655 IF(metsol >= 4.AND.metsol < 7.AND. mbandw >= 0) THEN ! GMRES/MINRES algorithms
8656 ! array space is:
8657 ! variable-width band matrix or diagonal matrix for parameters
8658 ! followed by symmetric matrix for constraints
8659 ! followed by rectangular matrix for constraints
8660 nwrdpc=0
8661 ncon=nagb-nvgb ! number of Lagrange multipliers
8662 ! constraint block info
8663 length=4*ncblck; IF(ncon == 0) length=0
8664 CALL mpalloc(blockprecond,length,'preconditioner: constraint blocks')
8665 length=ncon
8666 CALL mpalloc(offprecond,length,'preconditioner: constraint offsets')
8667 !END IF
8668 ! variable-width band matrix ?
8669 IF(mbandw > 0) THEN
8670 length=nagb
8671 CALL mpalloc(indprecond,length,'pointer-array variable-band matrix')
8672 nwrdpc=nwrdpc+length
8673 DO i=1,min(mbandw,nvgb)
8674 indprecond(i)=(i*i+i)/2 ! increasing number
8675 END DO
8676 DO i=min(mbandw,nvgb)+1,nvgb
8677 indprecond(i)=indprecond(i-1)+mbandw ! fixed band width
8678 END DO
8679 DO i=nvgb+1,nagb ! reset
8680 indprecond(i)=0
8681 END DO
8682 END IF
8683 ! symmetric part
8684 length=(ncon*ncon+ncon)/2
8685 ! add 'band' part
8686 IF(mbandw > 0) THEN ! variable-width band matrix
8687 length=length+indprecond(nvgb)
8688 ELSE ! default preconditioner (diagonal)
8689 length=length+nvgb
8690 END IF
8691 ! add rectangular part (compressed, constraint blocks)
8692 IF(ncon > 0) THEN
8693 ioff=0
8694 ! extra space (for forward solution in EQUDEC)
8695 nextra=max(0,mbandw-1)
8696 DO ib=1,ncblck
8697 ! first constraint in block
8698 blockprecond(ioff+1)=matconsblocks(1,ib)
8699 ! last constraint in block
8700 blockprecond(ioff+2)=matconsblocks(1,ib+1)-1
8701 ! parameter offset
8702 ipar0=matconsblocks(2,ib)-1
8703 blockprecond(ioff+3)=ipar0
8704 ! number of parameters (-> columns)
8705 npar=matconsblocks(3,ib)-ipar0
8706 blockprecond(ioff+4)=npar+nextra
8707 DO i=blockprecond(ioff+1),blockprecond(ioff+2)
8708 offprecond(i)=length-ipar0
8709 length=length+npar+nextra
8710 mszpcc=mszpcc+npar+nextra
8711 END DO
8712 ioff=ioff+4
8713 END DO
8714 ELSE
8715 IF(mbandw == 0) length=length+1 ! for valid precons argument matPreCond((ncon*ncon+ncon)/2+nvgb+1)
8716 END IF
8717 ! allocate
8718 IF(mbandw > 0) THEN
8719 CALL mpalloc(matprecond,length,'variable-band preconditioner matrix')
8720 ELSE
8721 CALL mpalloc(matprecond,length,'default preconditioner matrix')
8722 END IF
8723 nwrdpc=nwrdpc+2*length
8724 IF (nwrdpc > 250000) THEN
8725 WRITE(*,*)
8726 WRITE(*,*) 'Size of preconditioner matrix:',int(real(nwrdpc,mps)*4.0e-6,mpi),' MB'
8727 END IF
8728
8729 END IF
8730
8731
8732 length=nagb
8733 CALL mpalloc(globalcorrections,length,'corrections') ! double prec corrections
8734
8735 length=nagb
8736 CALL mpalloc(workspaced,length,'auxiliary array (D1)') ! double aux 1
8737 CALL mpalloc(workspacelinesearch,length,'auxiliary array (D2)') ! double aux 2
8738 CALL mpalloc(workspacei, length,'auxiliary array (I)') ! int aux 1
8739
8740 IF(metsol == 1) THEN
8741 CALL mpalloc(workspacediag,length,'diagonal of global matrix)') ! double aux 1
8742 CALL mpalloc(workspacerow,length,'(pivot) row of global matrix)')
8743 ! CALL MEGARR('t D',2*NAGB,'auxiliary array') ! double aux 8
8744 END IF
8745
8746 IF(metsol == 2) THEN
8747 IF(nagb>46300) THEN
8748 CALL peend(23,'Aborted, bad matrix index (will exceed 32bit)')
8749 stop 'vmprep: bad index (matrix to large for diagonalization)'
8750 END IF
8751 CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8752 CALL mpalloc(workspacediagonalization,length,'auxiliary array (D3)') ! double aux 3
8753 CALL mpalloc(workspaceeigenvalues,length,'auxiliary array (D6)') ! double aux 6
8754 length=nagb*nagb
8755 CALL mpalloc(workspaceeigenvectors,length,'(rotation) matrix U') ! rotation matrix
8756 END IF
8757
8758 IF(metsol >= 4.AND.metsol < 7) THEN
8759 CALL mpalloc(vecxav,length,'vector X (AVPROD)') ! double aux 1
8760 CALL mpalloc(vecbav,length,'vector B (AVPROD)') ! double aux 1
8761 END IF
8762
8763#ifdef LAPACK64
8764 IF(metsol == 7) THEN
8765 IF(nagb > nvgb) CALL mpalloc(lapackipiv, length,'IPIV for DSPTRG (L)') ! pivot indices for DSPTRF
8766 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8767 END IF
8768 IF(metsol == 8) THEN
8769 IF(nagb > nvgb) THEN
8770 CALL mpalloc(lapackipiv, length,'LAPACK IPIV (L)')
8771 nbopt = ilaenv( 1_mpl, 'DSYTRF', 'U', int(nagb,mpl), int(nagb,mpl), -1_mpl, -1_mpl ) ! optimal block size
8772 print *
8773 print *, 'LAPACK optimal block size for DSYTRF:', nbopt
8774 lplwrk=length*int(nbopt,mpl)
8775 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8776 ELSE IF(nfgb < nvgb.AND.icelim > 1) THEN
8777 ! elimination of constraints with LAPACK
8778 lplwrk=1
8779 DO i=1,npblck
8780 npar=matparblockoffsets(1,i+1)-matparblockoffsets(1,i) ! number of parameters in block
8781 ncon=vecparblockconoffsets(i+1)-vecparblockconoffsets(i) ! number of constraints in block
8782 nbopt = ilaenv( 1_mpl, 'DORMQL', 'RN', int(npar,mpl), int(npar,mpl), int(ncon,mpl), int(npar,mpl) ) ! optimal buffer size
8783 IF (int(npar,mpl)*int(nbopt,mpl) > lplwrk) THEN
8784 lplwrk=int(npar,mpl)*int(nbopt,mpl)
8785 nboptx=nbopt
8786 END IF
8787 END DO
8788 print *
8789 print *, 'LAPACK optimal block size for DORMQL:', nboptx
8790 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8791 END IF
8792 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8793 END IF
8794#endif
8795
8796END SUBROUTINE vmprep
8797
8801
8802SUBROUTINE minver
8803 USE mpmod
8804
8805 IMPLICIT NONE
8806 INTEGER(mpi) :: i
8807 INTEGER(mpi) :: ib
8808 INTEGER(mpi) :: icoff
8809 INTEGER(mpi) :: ipoff
8810 INTEGER(mpi) :: j
8811 INTEGER(mpi) :: lun
8812 INTEGER(mpi) :: ncon
8813 INTEGER(mpi) :: nfit
8814 INTEGER(mpi) :: npar
8815 INTEGER(mpi) :: nrank
8816 INTEGER(mpl) :: imoff
8817 INTEGER(mpl) :: ioff1
8818 REAL(mpd) :: matij
8819
8820 EXTERNAL avprds
8821
8822 SAVE
8823 ! ...
8824 lun=lunlog ! log file
8825
8826 IF(icalcm == 1) THEN
8827 ! save diagonal (for global correlation)
8828 DO i=1,nagb
8829 workspacediag(i)=matij(i,i)
8830 END DO
8831 ! use elimination for constraints ?
8832 IF(nfgb < nvgb) THEN
8833 ! monitor progress
8834 IF(monpg1 > 0) THEN
8835 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
8836 CALL monini(lunlog,monpg1,monpg2)
8837 END IF
8838 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
8839 IF(monpg1 > 0) CALL monend()
8840 END IF
8841 END IF
8842
8843 ! loop over blocks (multiple blocks only with elimination !)
8844 DO ib=1,npblck
8845 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
8846 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
8847 icoff=vecparblockconoffsets(ib) ! constraint offset for block
8848 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
8849 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
8850 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
8851 ! use elimination for constraints ?
8852 IF(nfit < npar) THEN
8853 CALL qlsetb(ib)
8854 ! solve L^t*y=d by backward substitution
8855 CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
8856 ! transform, reduce rhs
8857 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
8858 ! correction from eliminated part
8859 DO i=1,nfit
8860 DO j=1,ncon
8861 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
8862 globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
8863 END DO
8864 END DO
8865 END IF
8866
8867 IF(icalcm == 1) THEN
8868 ! monitor progress
8869 IF(monpg1 > 0) THEN
8870 WRITE(lunlog,*) 'Inversion of global matrix (A->A^-1)'
8871 CALL monini(lunlog,monpg1,monpg2)
8872 END IF
8873 ! invert and solve
8874 CALL sqminl(globalmatd(imoff+1:), globalcorrections(ipoff+1:),nfit,nrank, &
8875 workspaced,workspacei,workspacerow,monpg1)
8876 IF(monpg1 > 0) CALL monend()
8877 IF(nfit /= nrank) THEN
8878 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
8879 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
8880 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
8881 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
8882 IF (iforce == 0 .AND. isubit == 0) THEN
8883 isubit=1
8884 WRITE(*,*) ' --> enforcing SUBITO mode'
8885 WRITE(lun,*) ' --> enforcing SUBITO mode'
8886 END IF
8887 ELSE IF(ndefec == 0) THEN
8888 IF(npblck == 1) THEN
8889 WRITE(lun,*) 'No rank defect of the symmetric matrix'
8890 ELSE
8891 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
8892 END IF
8893 END IF
8894 ndefec=ndefec+nfit-nrank ! rank defect
8895
8896 ELSE ! multiply gradient by inverse matrix
8897 workspaced(:nfit)=globalcorrections(ipoff+1:ipoff+nfit)
8898 CALL dbsvxl(globalmatd(imoff+1:),workspaced,globalcorrections(ipoff+1:),nfit)
8899 END IF
8900
8901 !use elimination for constraints ?
8902 IF(nfit < npar) THEN
8903 ! extend, transform back solution
8904 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
8905 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
8906 END IF
8907 END DO
8908
8909END SUBROUTINE minver
8910
8914
8915SUBROUTINE mchdec
8916 USE mpmod
8917
8918 IMPLICIT NONE
8919 INTEGER(mpi) :: i
8920 INTEGER(mpi) :: ib
8921 INTEGER(mpi) :: icoff
8922 INTEGER(mpi) :: ipoff
8923 INTEGER(mpi) :: j
8924 INTEGER(mpi) :: lun
8925 INTEGER(mpi) :: ncon
8926 INTEGER(mpi) :: nfit
8927 INTEGER(mpi) :: npar
8928 INTEGER(mpi) :: nrank
8929 INTEGER(mpl) :: imoff
8930 INTEGER(mpl) :: ioff1
8931
8932 REAL(mpd) :: evmax
8933 REAL(mpd) :: evmin
8934
8935 EXTERNAL avprds
8936
8937 SAVE
8938 ! ...
8939 lun=lunlog ! log file
8940
8941 IF(icalcm == 1) THEN
8942 ! use elimination for constraints ?
8943 ! monitor progress
8944 IF(monpg1 > 0) THEN
8945 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
8946 CALL monini(lunlog,monpg1,monpg2)
8947 END IF
8948 IF(nfgb < nvgb) CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
8949 IF(monpg1 > 0) CALL monend()
8950 END IF
8951
8952 ! loop over blocks (multiple blocks only with elimination !)
8953 DO ib=1,npblck
8954 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
8955 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
8956 icoff=vecparblockconoffsets(ib) ! constraint offset for block
8957 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
8958 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
8959 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
8960 ! use elimination for constraints ?
8961 IF(nfit < npar) THEN
8962 CALL qlsetb(ib)
8963 ! solve L^t*y=d by backward substitution
8964 CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
8965 ! transform, reduce rhs
8966 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
8967 ! correction from eliminated part
8968 DO i=1,nfit
8969 DO j=1,ncon
8970 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
8971 globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
8972 END DO
8973 END DO
8974 END IF
8975
8976 IF(icalcm == 1) THEN
8977 ! monitor progress
8978 IF(monpg1 > 0) THEN
8979 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
8980 CALL monini(lunlog,monpg1,monpg2)
8981 END IF
8982 ! decompose and solve
8983 CALL chdec2(globalmatd(imoff+1:),nfit,nrank,evmax,evmin,monpg1)
8984 IF(monpg1 > 0) CALL monend()
8985 IF(nfit /= nrank) THEN
8986 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
8987 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
8988 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
8989 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
8990 IF (iforce == 0 .AND. isubit == 0) THEN
8991 isubit=1
8992 WRITE(*,*) ' --> enforcing SUBITO mode'
8993 WRITE(lun,*) ' --> enforcing SUBITO mode'
8994 END IF
8995 ELSE IF(ndefec == 0) THEN
8996 IF(npblck == 1) THEN
8997 WRITE(lun,*) 'No rank defect of the symmetric matrix'
8998 ELSE
8999 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9000 END IF
9001 WRITE(lun,*) ' largest diagonal element (LDLt)', evmax
9002 WRITE(lun,*) ' smallest diagonal element (LDLt)', evmin
9003 END IF
9004 ndefec=ndefec+nfit-nrank ! rank defect
9005
9006 END IF
9007 ! backward/forward substitution
9008 CALL chslv2(globalmatd(imoff+1:),globalcorrections(ipoff+1:),nfit)
9009
9010 !use elimination for constraints ?
9011 IF(nfit < npar) THEN
9012 ! extend, transform back solution
9013 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9014 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9015 END IF
9016 END DO
9017
9018END SUBROUTINE mchdec
9019
9020#ifdef LAPACK64
9021
9026
9027SUBROUTINE mdptrf
9028 USE mpmod
9029
9030 IMPLICIT NONE
9031 INTEGER(mpi) :: i
9032 INTEGER(mpi) :: ib
9033 INTEGER(mpi) :: icoff
9034 INTEGER(mpi) :: ipoff
9035 INTEGER(mpi) :: j
9036 INTEGER(mpi) :: lun
9037 INTEGER(mpi) :: ncon
9038 INTEGER(mpi) :: nfit
9039 INTEGER(mpi) :: npar
9040 INTEGER(mpl) :: imoff
9041 INTEGER(mpl) :: ioff1
9042 INTEGER(mpi) :: infolp
9043 REAL(mpd) :: matij
9044
9045 EXTERNAL avprds
9046
9047 SAVE
9048 ! ...
9049 lun=lunlog ! log file
9050
9051 IF(icalcm == 1) THEN
9052 IF(ilperr == 1) THEN
9053 ! save diagonal (for global correlation)
9054 DO i=1,nagb
9055 workspacediag(i)=matij(i,i)
9056 END DO
9057 END IF
9058 ! use elimination for constraints ?
9059 IF(nfgb < nvgb) THEN
9060 ! monitor progress
9061 IF(monpg1 > 0) THEN
9062 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9063 CALL monini(lunlog,monpg1,monpg2)
9064 END IF
9065 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9066 IF(monpg1 > 0) CALL monend()
9067 END IF
9068 END IF
9069
9070 ! loop over blocks (multiple blocks only with elimination !)
9071 DO ib=1,npblck
9072 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9073 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9074 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9075 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9076 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9077 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9078 ! use elimination for constraints ?
9079 IF(nfit < npar) THEN
9080 CALL qlsetb(ib)
9081 ! solve L^t*y=d by backward substitution
9082 CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
9083 ! transform, reduce rhs
9084 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9085 ! correction from eliminated part
9086 DO i=1,nfit
9087 DO j=1,ncon
9088 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9089 globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
9090 END DO
9091 END DO
9092 END IF
9093
9094 IF(icalcm == 1) THEN
9095 ! multipliers?
9096 IF (nfit > npar) THEN
9097 ! monitor progress
9098 IF(monpg1 > 0) THEN
9099 WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
9100 CALL monini(lunlog,monpg1,monpg2)
9101 END IF
9102 !$POMP INST BEGIN(dsptrf)
9103 CALL dsptrf('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),infolp)
9104 !$POMP INST END(dsptrf)
9105 IF(monpg1 > 0) CALL monend()
9106 ELSE
9107 ! monitor progress
9108 IF(monpg1 > 0) THEN
9109 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9110 CALL monini(lunlog,monpg1,monpg2)
9111 END IF
9112 !$POMP INST BEGIN(dpptrf)
9113 CALL dpptrf('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
9114 !$POMP INST END(dpptrf)
9115 IF(monpg1 > 0) CALL monend()
9116 ENDIF
9117 ! check result
9118 IF(infolp==0) THEN
9119 IF(npblck == 1) THEN
9120 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9121 ELSE
9122 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9123 END IF
9124 ELSE
9125 ndefec=ndefec+1 ! (lower limit of) rank defect
9126 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9127 '-by-',nfit,' failed at index ', infolp
9128 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9129 '-by-',nfit,' failed at index ', infolp
9130 CALL peend(29,'Aborted, factorization of global matrix failed')
9131 stop 'mdptrf: bad matrix'
9132 END IF
9133 END IF
9134 ! backward/forward substitution
9135 ! multipliers?
9136 IF (nfit > npar) THEN
9137 CALL dsptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),lapackipiv(ipoff+1:),&
9138 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9139 IF(infolp /= 0) print *, ' DSPTRS failed: ', infolp
9140 ELSE
9141 CALL dpptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),&
9142 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9143 IF(infolp /= 0) print *, ' DPPTRS failed: ', infolp
9144 ENDIF
9145
9146 !use elimination for constraints ?
9147 IF(nfit < npar) THEN
9148 ! extend, transform back solution
9149 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9150 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9151 END IF
9152 END DO
9153
9154END SUBROUTINE mdptrf
9155
9161
9162SUBROUTINE mdutrf
9163 USE mpmod
9164
9165 IMPLICIT NONE
9166 INTEGER(mpi) :: i
9167 INTEGER(mpi) :: ib
9168 INTEGER(mpi) :: icoff
9169 INTEGER(mpi) :: ipoff
9170 INTEGER(mpi) :: j
9171 INTEGER(mpi) :: lun
9172 INTEGER(mpi) :: ncon
9173 INTEGER(mpi) :: nfit
9174 INTEGER(mpi) :: npar
9175 INTEGER(mpl) :: imoff
9176 INTEGER(mpl) :: ioff1
9177 INTEGER(mpl) :: iloff
9178 INTEGER(mpi) :: infolp
9179
9180 REAL(mpd) :: matij
9181
9182 EXTERNAL avprds
9183
9184 SAVE
9185 ! ...
9186 lun=lunlog ! log file
9187
9188 IF(icalcm == 1) THEN
9189 IF(ilperr == 1) THEN
9190 ! save diagonal (for global correlation)
9191 DO i=1,nagb
9192 workspacediag(i)=matij(i,i)
9193 END DO
9194 END IF
9195 ! use elimination for constraints ?
9196 IF(nfgb < nvgb) THEN
9197 ! monitor progress
9198 IF(monpg1 > 0) THEN
9199 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9200 CALL monini(lunlog,monpg1,monpg2)
9201 END IF
9202 IF (icelim > 1) THEN
9203 CALL lpavat(.true.)
9204 ELSE
9205 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9206 END IF
9207 IF(monpg1 > 0) CALL monend()
9208 END IF
9209 END IF
9210
9211 ! loop over blocks (multiple blocks only with elimination !)
9212 iloff=0 ! offset of L in lapackQL
9213 DO ib=1,npblck
9214 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9215 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9216 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9217 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9218 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9219 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9220 ! use elimination for constraints ?
9221 IF(nfit < npar) THEN
9222 IF (icelim > 1) THEN
9223 ! solve L^t*y=d by backward substitution
9224 vecconssolution(1:ncon)=vecconsresiduals(icoff+1:icoff+ncon)
9225 CALL dtrtrs('L','T','N',int(ncon,mpl),1_mpl,lapackql(iloff+npar-ncon+1:),int(npar,mpl),&
9226 vecconssolution,int(ncon,mpl),infolp)
9227 IF(infolp /= 0) print *, ' DTRTRS failed: ', infolp
9228 ! transform, reduce rhs, Q^t*b
9229 CALL dormql('L','T',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9230 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9231 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9232 ELSE
9233 CALL qlsetb(ib)
9234 ! solve L^t*y=d by backward substitution
9235 CALL qlbsub(vecconsresiduals(icoff+1:),vecconssolution)
9236 ! transform, reduce rhs
9237 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9238 END IF
9239 ! correction from eliminated part
9240 DO i=1,nfit
9241 DO j=1,ncon
9242 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9243 globalcorrections(i+ipoff)=globalcorrections(i+ipoff)-globalmatd(ioff1)*vecconssolution(j)
9244 END DO
9245 END DO
9246 END IF
9247
9248 IF(icalcm == 1) THEN
9249 ! multipliers?
9250 IF (nfit > npar) THEN
9251 ! monitor progress
9252 IF(monpg1 > 0) THEN
9253 WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
9254 CALL monini(lunlog,monpg1,monpg2)
9255 END IF
9256 !$POMP INST BEGIN(dsytrf)
9257 CALL dsytrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
9258 lapackipiv(ipoff+1:),lapackwork,lplwrk,infolp)
9259 !$POMP INST END(dsytrf)
9260 IF(monpg1 > 0) CALL monend()
9261 ELSE
9262 ! monitor progress
9263 IF(monpg1 > 0) THEN
9264 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9265 CALL monini(lunlog,monpg1,monpg2)
9266 END IF
9267 !$POMP INST BEGIN(dpotrf)
9268 CALL dpotrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
9269 !$POMP INST END(dpotrf)
9270 IF(monpg1 > 0) CALL monend()
9271 ENDIF
9272 ! check result
9273 IF(infolp==0) THEN
9274 IF(npblck == 1) THEN
9275 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9276 ELSE
9277 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9278 END IF
9279 ELSE
9280 ndefec=ndefec+1 ! (lower limit of) rank defect
9281 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9282 '-by-',nfit,' failed at index ', infolp
9283 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9284 '-by-',nfit,' failed at index ', infolp
9285 CALL peend(29,'Aborted, factorization of global matrix failed')
9286 stop 'mdutrf: bad matrix'
9287 END IF
9288 END IF
9289 ! backward/forward substitution
9290 ! multipliers?
9291 IF (nfit > npar) THEN
9292 CALL dsytrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(nfit,mpl),&
9293 lapackipiv(ipoff+1:),globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9294 IF(infolp /= 0) print *, ' DSYTRS failed: ', infolp
9295 ELSE
9296 CALL dpotrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(npar,mpl),&
9297 globalcorrections(ipoff+1:),int(npar,mpl),infolp)
9298 IF(infolp /= 0) print *, ' DPOTRS failed: ', infolp
9299 ENDIF
9300
9301 !use elimination for constraints ?
9302 IF(nfit < npar) THEN
9303 IF (icelim > 1) THEN
9304 ! correction from eliminated part
9305 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9306 ! extend, transform back solution, Q*x
9307 CALL dormql('L','N',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9308 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9309 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9310 ELSE
9311 ! extend, transform back solution
9312 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9313 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9314 END IF
9315 END IF
9316 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9317 END DO
9318
9319END SUBROUTINE mdutrf
9320
9331SUBROUTINE lpqldec(a,emin,emax)
9332 USE mpmod
9333 USE mpdalc
9334
9335 IMPLICIT NONE
9336 INTEGER(mpi) :: ib
9337 INTEGER(mpi) :: icb
9338 INTEGER(mpi) :: icboff
9339 INTEGER(mpi) :: icblst
9340 INTEGER(mpi) :: icoff
9341 INTEGER(mpi) :: icfrst
9342 INTEGER(mpi) :: iclast
9343 INTEGER(mpi) :: ipfrst
9344 INTEGER(mpi) :: iplast
9345 INTEGER(mpi) :: ipoff
9346 INTEGER(mpi) :: i
9347 INTEGER(mpi) :: j
9348 INTEGER(mpi) :: ncon
9349 INTEGER(mpi) :: npar
9350 INTEGER(mpi) :: npb
9351 INTEGER(mpl) :: imoff
9352 INTEGER(mpl) :: iloff
9353 INTEGER(mpi) :: infolp
9354 INTEGER :: nbopt, ILAENV
9355
9356 REAL(mpd), INTENT(IN) :: a(mszcon)
9357 REAL(mpd), INTENT(OUT) :: emin
9358 REAL(mpd), INTENT(OUT) :: emax
9359 SAVE
9360
9361 print *
9362 ! loop over blocks (multiple blocks only with elimination !)
9363 iloff=0 ! size of unpacked constraint matrix
9364 DO ib=1,npblck
9365 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9366 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9367 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9368 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9369 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9370 END DO
9371 ! allocate
9372 CALL mpalloc(lapackql, iloff, 'LAPACK QL (QL decomp.) ')
9373 lapackql=0.
9374 iloff=ncgb
9375 CALL mpalloc(lapacktau, iloff, 'LAPACK TAU (QL decomp.) ')
9376 ! fill
9377 iloff=0 ! offset of unpacked constraint matrix block
9378 imoff=0 ! offset of packed constraint matrix block
9379 DO ib=1,npblck
9380 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9381 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9382 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9383 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9384 IF(ncon <= 0) cycle
9385 ! block with constraints
9386 icboff=matparblockoffsets(2,ib) ! constraint block offset
9387 icblst=matparblockoffsets(2,ib+1) ! constraint block offset
9388 DO icb=icboff+1,icboff+icblst
9389 icfrst=matconsblocks(1,icb) ! first constraint in block
9390 iclast=matconsblocks(1,icb+1)-1 ! last constraint in block
9391 DO j=icfrst,iclast
9392 ipfrst=matconsranges(3,j)-ipoff ! first (rel.) parameter
9393 iplast=matconsranges(4,j)-ipoff ! last (rel.) parameters
9394 npb=iplast-ipfrst+1
9395 lapackql(iloff+ipfrst:iloff+iplast)=a(imoff+1:imoff+npb)
9396 imoff=imoff+npb
9397 iloff=iloff+npar
9398 END DO
9399 END DO
9400 END DO
9401 ! decompose
9402 iloff=0 ! offset of unpacked constraint matrix block
9403 emax=-1.
9404 emin=1.
9405 DO ib=1,npblck
9406 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9407 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9408 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9409 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9410 IF(ncon <= 0) cycle
9411 ! block with constraints
9412 nbopt = ilaenv( 1_mpl, 'DGEQLF', '', int(npar,mpl), int(ncon,mpl), int(npar,mpl), -1_mpl ) ! optimal block size
9413 print *, 'LAPACK optimal block size for DGEQLF:', nbopt
9414 lplwrk=int(ncon,mpl)*int(nbopt,mpl)
9415 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (d)')
9416 !$POMP INST BEGIN(dgeqlf)
9417 CALL dgeqlf(int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9418 lapacktau(icoff+1:),lapackwork,lplwrk,infolp)
9419 IF(infolp /= 0) print *, ' DGEQLF failed: ', infolp
9420 !$POMP INST END(dgeqlf)
9421 CALL mpdealloc(lapackwork)
9422 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9423 ! get min/max diaginal element of L
9424 imoff=iloff
9425 IF(emax < emin) THEN
9426 emax=lapackql(imoff)
9427 emin=emax
9428 END IF
9429 DO i=1,ncon
9430 IF (abs(emax) < abs(lapackql(imoff))) emax=lapackql(imoff)
9431 IF (abs(emin) > abs(lapackql(imoff))) emin=lapackql(imoff)
9432 imoff=imoff-npar-1
9433 END DO
9434 END DO
9435 print *
9436END SUBROUTINE lpqldec
9437
9447SUBROUTINE lpavat(t)
9448 USE mpmod
9449
9450 IMPLICIT NONE
9451 INTEGER(mpi) :: i
9452 INTEGER(mpi) :: ib
9453 INTEGER(mpi) :: icoff
9454 INTEGER(mpi) :: ipoff
9455 INTEGER(mpi) :: j
9456 INTEGER(mpi) :: ncon
9457 INTEGER(mpi) :: npar
9458 INTEGER(mpl) :: imoff
9459 INTEGER(mpl) :: iloff
9460 INTEGER(mpi) :: infolp
9461 CHARACTER (LEN=1) :: transr, transl
9462
9463 LOGICAL, INTENT(IN) :: t
9464 SAVE
9465
9466 IF (t) THEN ! Q^t*A*Q
9467 transr='N'
9468 transl='T'
9469 ELSE ! Q*A*Q^t
9470 transr='T'
9471 transl='N'
9472 ENDIF
9473
9474 ! loop over blocks (multiple blocks only with elimination !)
9475 iloff=0 ! offset of L in lapackQL
9476 DO ib=1,npblck
9477 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9478 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9479 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9480 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9481 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9482 IF(ncon <= 0 ) cycle
9483
9484 !$POMP INST BEGIN(dormql)
9485 ! expand matrix (copy lower to upper triangle)
9486 ! parallelize row loop
9487 ! slot of 32 'I' for next idle thread
9488 !$OMP PARALLEL DO &
9489 !$OMP PRIVATE(J) &
9490 !$OMP SCHEDULE(DYNAMIC,32)
9491 DO i=ipoff+1,ipoff+npar
9492 DO j=ipoff+1,i-1
9493 globalmatd(globalrowoffsets(j)+i)=globalmatd(globalrowoffsets(i)+j)
9494 ENDDO
9495 ENDDO
9496 ! A*Q
9497 CALL dormql('R',transr,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9498 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9499 lapackwork,lplwrk,infolp)
9500 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9501 ! Q^t*(A*Q)
9502 CALL dormql('L',transl,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9503 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9504 lapackwork,lplwrk,infolp)
9505 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9506 !$POMP INST END(dormql)
9507
9508 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9509 END DO
9510
9511END SUBROUTINE lpavat
9512
9513#ifdef PARDISO
9514include 'mkl_pardiso.f90'
9515!===============================================================================
9516! Copyright 2004-2022 Intel Corporation.
9517!
9518! This software and the related documents are Intel copyrighted materials, and
9519! your use of them is governed by the express license under which they were
9520! provided to you (License). Unless the License provides otherwise, you may not
9521! use, modify, copy, publish, distribute, disclose or transmit this software or
9522! the related documents without Intel's prior written permission.
9523!
9524! This software and the related documents are provided as is, with no express
9525! or implied warranties, other than those that are expressly stated in the
9526! License.
9527!===============================================================================
9528!
9529! Content : Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO Fortran-90
9530! use case
9531!
9532!*******************************************************************************
9533
9538SUBROUTINE mspardiso
9539 USE mkl_pardiso
9540 USE mpmod
9541 USE mpdalc
9542 IMPLICIT NONE
9543
9544 !.. Internal solver memory pointer
9545 TYPE(mkl_pardiso_handle) :: pt(64) ! Handle to internal data structure
9546 !.. All other variables
9547 INTEGER(mpl), PARAMETER :: maxfct =1 ! Max. number of factors with identical sparsity structure kept in memory
9548 INTEGER(mpl), PARAMETER :: mnum = 1 ! Actual factor to use
9549 INTEGER(mpl), PARAMETER :: nrhs = 1 ! Number of right hand sides
9550
9551 INTEGER(mpl) :: mtype ! Matrix type (symmetric, pos. def.: 2, indef.: -2)
9552 INTEGER(mpl) :: phase ! Solver phase(s) to be executed
9553 INTEGER(mpl) :: error ! Error code
9554 INTEGER(mpl) :: msglvl ! Message level
9555
9556 INTEGER(mpi) :: i
9557 INTEGER(mpl) :: ij
9558 INTEGER(mpl) :: idum(1)
9559 INTEGER(mpi) :: lun
9560 INTEGER(mpl) :: length
9561 INTEGER(mpi) :: nfill
9562 INTEGER(mpi) :: npdblk
9563 REAL(mpd) :: adum(1)
9564 REAL(mpd) :: ddum(1)
9565
9566 INTEGER(mpl) :: iparm(64)
9567 REAL(mpd), ALLOCATABLE :: b( : ) ! Right hand side (of equations system)
9568 REAL(mpd), ALLOCATABLE :: x( : ) ! Solution (of equations system)
9569 SAVE
9570
9571 lun=lunlog ! log file
9572
9573 error = 0 ! initialize error flag
9574 msglvl = ipddbg ! print statistical information
9575 npdblk=(nfgb-1)/matbsz+1 ! number of row blocks
9576
9577 IF(icalcm == 1) THEN
9578 mtype = 2 ! positive definite symmetric matrix
9579 IF (nfgb > nvgb) mtype = -2 ! indefinte symmetric matrix (Lagrange multipliers)
9580
9581 !$POMP INST BEGIN(mspd00)
9582 WRITE(*,*)
9583 WRITE(*,*) 'MSPARDISO: number of non-zero elements = ', csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
9584 ! fill up last block?
9585 nfill = npdblk*matbsz-nfgb
9586 IF (nfill > 0) THEN
9587 WRITE(*,*) 'MSPARDISO: number of rows to fill up = ', nfill
9588 ! end of last block
9589 ij = (csr3rowoffsets(npdblk+1)-csr3rowoffsets(1))*int(matbsz,mpl)*int(matbsz,mpl)
9590 DO i=1,nfill
9591 globalmatd(ij) = 1.0_mpd
9592 ij = ij-matbsz-1 ! back one row and one column in last block
9593 END DO
9594 END IF
9595
9596 ! close previous PARADISO run
9597 IF (ipdmem > 0) THEN
9598 !.. Termination and release of memory
9599 phase = -1 ! release internal memory
9600 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), adum, idum, idum, &
9601 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9602 IF (error /= 0) THEN
9603 WRITE(lun,*) 'The following ERROR was detected: ', error
9604 WRITE(*,'(A,2I10)') ' PARDISO release failed (phase, error): ', phase, error
9605 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9606 CALL peend(40,'Aborted, other error: PARDISO release')
9607 stop 'MSPARDISO: stopping due to error in PARDISO release'
9608 END IF
9609 ipdmem=0
9610 END IF
9611
9612 !..
9613 !.. Set up PARDISO control parameter
9614 !..
9615 iparm=0 ! using defaults
9616 iparm(2) = 2 ! fill-in reordering from METIS
9617 iparm(10) = 8 ! perturb the pivot elements with 1E-8
9618 iparm(18) = -1 ! Output: number of nonzeros in the factor LU
9619 iparm(19) = -1 ! Output: Mflops for LU factorization
9620 iparm(21) = 1 ! pivoting for symmetric indefinite matrices
9621 DO i=1, lenpardiso
9622 iparm(listpardiso(i)%label)=listpardiso(i)%ivalue
9623 END DO
9624 IF (iparm(1) == 0) WRITE(lun,*) 'PARDISO using defaults '
9625 IF (iparm(43) /= 0) THEN
9626 WRITE(lun,*) 'PARDISO: computation of the diagonal of inverse matrix not implemented !'
9627 iparm(43) = 0 ! no computation of the diagonal of inverse matrix
9628 END IF
9629
9630 ! necessary for the FIRST call of the PARDISO solver.
9631 DO i = 1, 64
9632 pt(i)%DUMMY = 0
9633 END DO
9634 !$POMP INST END(mspd00)
9635 END IF
9636
9637 IF(icalcm == 1) THEN
9638 ! monitor progress
9639 IF(monpg1 > 0) THEN
9640 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
9641 CALL monini(lunlog,monpg1,monpg2)
9642 END IF
9643 ! decompose and solve
9644 !.. Reordering and Symbolic Factorization, This step also allocates
9645 ! all memory that is necessary for the factorization
9646 !$POMP INST BEGIN(mspd11)
9647 phase = 11 ! only reordering and symbolic factorization
9648 IF (matbsz > 1) THEN
9649 iparm(1) = 1 ! non default setting
9650 iparm(37) = matbsz ! using BSR3 instead of CSR3
9651 END IF
9652 IF (ipddbg > 0) THEN
9653 DO i=1,64
9654 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9655 END DO
9656 END IF
9657 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9658 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9659 !$POMP INST END(mspd11)
9660 WRITE(lun,*) 'PARDISO reordering completed ... '
9661 WRITE(lun,*) 'PARDISO peak memory required (KB)', iparm(15)
9662 IF (ipddbg > 0) THEN
9663 DO i=1,64
9664 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9665 END DO
9666 END IF
9667 IF (error /= 0) THEN
9668 WRITE(lun,*) 'The following ERROR was detected: ', error
9669 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9670 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9671 CALL peend(40,'Aborted, other error: PARDISO reordering')
9672 stop 'MSPARDISO: stopping due to error in PARDISO reordering'
9673 END IF
9674 IF (iparm(60) == 0) THEN
9675 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(17) ! in core
9676 ELSE
9677 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(63) ! out of core
9678 END IF
9679 WRITE(lun,*) 'Size (KB) of allocated memory = ',ipdmem
9680 WRITE(lun,*) 'Number of nonzeros in factors = ',iparm(18)
9681 WRITE(lun,*) 'Number of factorization MFLOPS = ',iparm(19)
9682
9683 !.. Factorization.
9684 !$POMP INST BEGIN(mspd22)
9685 phase = 22 ! only factorization
9686 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9687 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9688 !$POMP INST END(mspd22)
9689 WRITE(lun,*) 'PARDISO factorization completed ... '
9690 IF (ipddbg > 0) THEN
9691 DO i=1,64
9692 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9693 END DO
9694 END IF
9695 IF (error /= 0) THEN
9696 WRITE(lun,*) 'The following ERROR was detected: ', error
9697 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9698 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9699 CALL peend(40,'Aborted, other error: PARDISO factorization')
9700 stop 'MSPARDISO: stopping due to error in PARDISO factorization'
9701 ENDIF
9702 IF (mtype < 0) THEN
9703 IF (iparm(14) > 0) &
9704 WRITE(lun,*) 'Number of perturbed pivots = ',iparm(14)
9705 WRITE(lun,*) 'Number of positive eigenvalues = ',iparm(22)-nfill
9706 WRITE(lun,*) 'Number of negative eigenvalues = ',iparm(23)
9707 ELSE IF (iparm(30) > 0) THEN
9708 WRITE(lun,*) 'Equation with bad pivot (<=0.) = ',iparm(30)
9709 END IF
9710
9711 IF (monpg1 > 0) CALL monend()
9712 END IF
9713
9714 ! backward/forward substitution
9715 !.. Back substitution and iterative refinement
9716 length=nfgb+nfill
9717 CALL mpalloc(b,length,' PARDISO r.h.s')
9718 CALL mpalloc(x,length,' PARDISO solution')
9719 b(:nfgb) = globalcorrections
9720 !$POMP INST BEGIN(mspd33)
9721 iparm(6) = 0 ! don't update r.h.s. with solution
9722 phase = 33 ! only solving
9723 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9724 idum, nrhs, iparm, msglvl, b, x, error)
9725 !$POMP INST END(mspd33)
9726 globalcorrections = x(:nfgb)
9727 CALL mpdealloc(x)
9728 CALL mpdealloc(b)
9729 WRITE(lun,*) 'PARDISO solve completed ... '
9730 IF (error /= 0) THEN
9731 WRITE(lun,*) 'The following ERROR was detected: ', error
9732 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9733 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9734 CALL peend(40,'Aborted, other error: PARDISO solve')
9735 stop 'MSPARDISO: stopping due to error in PARDISO solve'
9736 ENDIF
9737
9738END SUBROUTINE mspardiso
9739#endif
9740#endif
9741
9743SUBROUTINE mdiags
9744 USE mpmod
9745
9746 IMPLICIT NONE
9747 REAL(mps) :: evalue
9748 INTEGER(mpi) :: i
9749 INTEGER(mpi) :: iast
9750 INTEGER(mpi) :: idia
9751 INTEGER(mpi) :: imin
9752 INTEGER(mpl) :: ioff1
9753 INTEGER(mpi) :: j
9754 INTEGER(mpi) :: last
9755 INTEGER(mpi) :: lun
9756 INTEGER(mpi) :: nmax
9757 INTEGER(mpi) :: nmin
9758 INTEGER(mpi) :: ntop
9759 REAL(mpd) :: matij
9760 !
9761 EXTERNAL avprds
9762
9763 SAVE
9764 ! ...
9765
9766 lun=lunlog ! log file
9767
9768 ! save diagonal (for global correlation)
9769 IF(icalcm == 1) THEN
9770 DO i=1,nagb
9771 workspacediag(i)=matij(i,i)
9772 END DO
9773 ENDIF
9774
9775 !use elimination for constraints ?
9776 IF(nfgb < nvgb) THEN
9777 IF(icalcm == 1) THEN
9778 ! monitor progress
9779 IF(monpg1 > 0) THEN
9780 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9781 CALL monini(lunlog,monpg1,monpg2)
9782 END IF
9783 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9784 IF(monpg1 > 0) CALL monend()
9785 ENDIF
9786 ! solve L^t*y=d by backward substitution
9787 CALL qlbsub(vecconsresiduals,vecconssolution)
9788 ! transform, reduce rhs
9789 CALL qlmlq(globalcorrections,1,.true.) ! Q^t*b
9790 ! correction from eliminated part
9791 DO i=1,nfgb
9792 DO j=1,ncgb
9793 ioff1=globalrowoffsets(nfgb+j)+i ! global (nfit+j,i)
9794 globalcorrections(i)=globalcorrections(i)-globalmatd(ioff1)*vecconssolution(j)
9795 END DO
9796 END DO
9797 END IF
9798
9799 IF(icalcm == 1) THEN
9800 ! eigenvalues eigenvectors symm_input
9801 workspaceeigenvalues=0.0_mpd
9802 CALL devrot(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalmatd, &
9803 workspacediagonalization,workspacei)
9804
9805 ! histogram of positive eigenvalues
9806
9807 nmax=int(1.0+log10(real(workspaceeigenvalues(1),mps)),mpi) ! > log of largest eigenvalue
9808 imin=1
9809 DO i=nfgb,1,-1
9810 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
9811 imin=i ! index of smallest pos. eigenvalue
9812 EXIT
9813 END IF
9814 END DO
9815 nmin=int(log10(real(workspaceeigenvalues(imin),mps)),mpi) ! log of smallest pos. eigenvalue
9816 ntop=nmin+6
9817 DO WHILE(ntop < nmax)
9818 ntop=ntop+3
9819 END DO
9820
9821 CALL hmpdef(7,real(nmin,mps),real(ntop,mps), 'log10 of positive eigenvalues')
9822 DO idia=1,nfgb
9823 IF(workspaceeigenvalues(idia) > 0.0_mpd) THEN ! positive
9824 evalue=log10(real(workspaceeigenvalues(idia),mps))
9825 CALL hmpent(7,evalue)
9826 END IF
9827 END DO
9828 IF(nhistp /= 0) CALL hmprnt(7)
9829 CALL hmpwrt(7)
9830
9831 iast=max(1,imin-60)
9832 CALL gmpdef(3,2,'low-value end of eigenvalues')
9833 DO i=iast,nfgb
9834 evalue=real(workspaceeigenvalues(i),mps)
9835 CALL gmpxy(3,real(i,mps),evalue)
9836 END DO
9837 IF(nhistp /= 0) CALL gmprnt(3)
9838 CALL gmpwrt(3)
9839
9840 DO i=1,nfgb
9841 workspacediagonalization(i)=0.0_mpd
9842 IF(workspaceeigenvalues(i) /= 0.0_mpd) THEN
9843 workspacediagonalization(i)=max(0.0_mpd,log10(abs(workspaceeigenvalues(i)))+3.0_mpd)
9844 IF(workspaceeigenvalues(i) < 0.0_mpd) workspacediagonalization(i)=-workspacediagonalization(i)
9845 END IF
9846 END DO
9847 last=min(nfgb,nvgb)
9848 WRITE(lun,*) ' '
9849 WRITE(lun,*) 'The first (largest) eigenvalues ...'
9850 WRITE(lun,102) (workspaceeigenvalues(i),i=1,min(20,nagb))
9851 WRITE(lun,*) ' '
9852 WRITE(lun,*) 'The last eigenvalues ... up to',last
9853 WRITE(lun,102) (workspaceeigenvalues(i),i=max(1,last-19),last)
9854 WRITE(lun,*) ' '
9855 IF(nagb > nvgb) THEN
9856 WRITE(lun,*) 'The eigenvalues from',nvgb+1,' to',nagb
9857 WRITE(lun,102) (workspaceeigenvalues(i),i=nvgb+1,nagb)
9858 WRITE(lun,*) ' '
9859 ENDIF
9860 WRITE(lun,*) 'Log10 + 3 of ',nfgb,' eigenvalues in decreasing', ' order'
9861 WRITE(lun,*) '(for Eigenvalue < 0.001 the value 0.0 is shown)'
9862 WRITE(lun,101) (workspacediagonalization(i),i=1,nfgb)
9863 IF(workspacediagonalization(nfgb) < 0) WRITE(lun,*) 'Negative values are ', &
9864 'printed for negative eigenvalues'
9865 CALL devsig(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalvector,workspacediagonalization)
9866 WRITE(lun,*) ' '
9867 WRITE(lun,*) last,' significances: insignificant if ', &
9868 'compatible with N(0,1)'
9869 WRITE(lun,101) (workspacediagonalization(i),i=1,last)
9870
9871
9872101 FORMAT(10f7.1)
9873102 FORMAT(5e14.6)
9874
9875 END IF
9876
9877 ! solution ---------------------------------------------------------
9878 workspaced(:nfgb)=globalcorrections(:nfgb)
9879 ! eigenvalues eigenvectors
9880 CALL devsol(nfgb,workspaceeigenvalues,workspaceeigenvectors,workspaced,globalcorrections,workspacediagonalization)
9881
9882 !use elimination for constraints ?
9883 IF(nfgb < nvgb) THEN
9884 ! extend, transform back solution
9885 globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
9886 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
9887 END IF
9888
9889END SUBROUTINE mdiags
9890
9892SUBROUTINE zdiags
9893 USE mpmod
9894
9895 IMPLICIT NONE
9896 INTEGER(mpi) :: i
9897 INTEGER(mpl) :: ioff1
9898 INTEGER(mpl) :: ioff2
9899 INTEGER(mpi) :: j
9900
9901 ! eigenvalue eigenvectors cov.matrix
9902 CALL devinv(nfgb,workspaceeigenvalues,workspaceeigenvectors,globalmatd) ! inv
9903
9904 !use elimination for constraints ?
9905 IF(nfgb < nvgb) THEN
9906 ! extend, transform eigenvectors
9907 ioff1=nfgb*nfgb
9908 ioff2=nfgb*nvgb
9909 workspaceeigenvectors(ioff2+1:)=0.0_mpd
9910 DO i=nfgb,1,-1
9911 ioff1=ioff1-nfgb
9912 ioff2=ioff2-nvgb
9913 DO j=nfgb,1,-1
9914 workspaceeigenvectors(ioff2+j)=workspaceeigenvectors(ioff1+j)
9915 END DO
9916 workspaceeigenvectors(ioff2+nfgb+1:ioff2+nvgb)=0.0_mpd
9917 END DO
9918 CALL qlmlq(workspaceeigenvectors,nvgb,.false.) ! Q*U
9919 END IF
9920
9921END SUBROUTINE zdiags
9922
9928
9929SUBROUTINE mminrs
9930 USE mpmod
9931 USE minresmodule, ONLY: minres
9932
9933 IMPLICIT NONE
9934 INTEGER(mpi) :: istop
9935 INTEGER(mpi) :: itn
9936 INTEGER(mpi) :: itnlim
9937 INTEGER(mpi) :: lun
9938 INTEGER(mpi) :: nout
9939 INTEGER(mpi) :: nrkd
9940 INTEGER(mpi) :: nrkd2
9941
9942 REAL(mpd) :: shift
9943 REAL(mpd) :: rtol
9944 REAL(mpd) :: anorm
9945 REAL(mpd) :: acond
9946 REAL(mpd) :: arnorm
9947 REAL(mpd) :: rnorm
9948 REAL(mpd) :: ynorm
9949 LOGICAL :: checka
9950 EXTERNAL avprds, avprod, mvsolv, mcsolv
9951 SAVE
9952 ! ...
9953 lun=lunlog ! log file
9954
9955 nout=lun
9956 itnlim=2000 ! iteration limit
9957 shift =0.0_mpd ! not used
9958 rtol = mrestl ! from steering
9959 checka=.false.
9960
9961 workspaced = globalcorrections
9962 !use elimination for constraints ?
9963 IF(nfgb < nvgb) THEN
9964 ! solve L^t*y=d by backward substitution
9965 CALL qlbsub(vecconsresiduals,vecconssolution)
9966 ! input to AVPRD0
9967 vecxav(1:nfgb)=0.0_mpd
9968 vecxav(nfgb+1:nagb)=vecconssolution
9969 CALL qlmlq(vecxav,1,.false.) ! Q*x
9970 ! calclulate vecBav=globalMat*vecXav
9971 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
9972 ! correction from eliminated part
9973 workspaced=workspaced-vecbav
9974 ! transform, reduce rhs
9975 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
9976 END IF
9977
9978 IF(mbandw == 0) THEN ! default preconditioner
9979 IF(icalcm == 1) THEN
9980 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
9981 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
9982 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
9983 CALL precons(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond,matprecond, &
9984 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
9985 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
9986 IF(monpg1 > 0) CALL monend()
9987 END IF
9988 CALL minres(nfgb, avprod, mcsolv, workspaced, shift, checka ,.true. , &
9989 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
9990 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
9991 IF(icalcm == 1) THEN
9992 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
9993 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
9994 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
9995 CALL equdecs(nprecond(2),nprecond(1),nprecond(3),mszpcc,lprecm,matprecond,indprecond,blockprecond,nrkd,nrkd2)
9996 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
9997 IF(monpg1 > 0) CALL monend()
9998 END IF
9999 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.true. , &
10000 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10001 ELSE
10002 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.false. , &
10003 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10004 END IF
10005
10006 !use elimination for constraints ?
10007 IF(nfgb < nvgb) THEN
10008 ! extend, transform back solution
10009 globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
10010 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10011 END IF
10012
10013 iitera=itn
10014 istopa=istop
10015 mnrsit=mnrsit+itn
10016
10017 IF (istopa == 0) print *, 'MINRES: istop=0, exact solution x=0.'
10018
10019END SUBROUTINE mminrs
10020
10026
10027SUBROUTINE mminrsqlp
10028 USE mpmod
10029 USE minresqlpmodule, ONLY: minresqlp
10030
10031 IMPLICIT NONE
10032 INTEGER(mpi) :: istop
10033 INTEGER(mpi) :: itn
10034 INTEGER(mpi) :: itnlim
10035 INTEGER(mpi) :: lun
10036 INTEGER(mpi) :: nout
10037 INTEGER(mpi) :: nrkd
10038 INTEGER(mpi) :: nrkd2
10039
10040 REAL(mpd) :: rtol
10041 REAL(mpd) :: mxxnrm
10042 REAL(mpd) :: trcond
10043
10044 EXTERNAL avprds, avprod, mvsolv, mcsolv
10045 SAVE
10046 ! ...
10047 lun=lunlog ! log file
10048
10049 nout=lun
10050 itnlim=2000 ! iteration limit
10051 rtol = mrestl ! from steering
10052 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
10053 IF(mrmode == 1) THEN
10054 trcond = 1.0_mpd/epsilon(trcond) ! only QR
10055 ELSE IF(mrmode == 2) THEN
10056 trcond = 1.0_mpd ! only QLP
10057 ELSE
10058 trcond = mrtcnd ! QR followed by QLP
10059 END IF
10060
10061 workspaced = globalcorrections
10062 !use elimination for constraints ?
10063 IF(nfgb < nvgb) THEN
10064 ! solve L^t*y=d by backward substitution
10065 CALL qlbsub(vecconsresiduals,vecconssolution)
10066 ! input to AVPRD0
10067 vecxav(1:nfgb)=0.0_mpd
10068 vecxav(nfgb+1:nagb)=vecconssolution
10069 CALL qlmlq(vecxav,1,.false.) ! Q*x
10070 ! calclulate vecBav=globalMat*vecXav
10071 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
10072 ! correction from eliminated part
10073 workspaced=workspaced-vecbav
10074 ! transform, reduce rhs
10075 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
10076 END IF
10077
10078 IF(mbandw == 0) THEN ! default preconditioner
10079 IF(icalcm == 1) THEN
10080 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
10081 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10082 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
10083 CALL precons(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond,matprecond, &
10084 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
10085 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
10086 IF(monpg1 > 0) CALL monend()
10087 END IF
10088 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mcsolv, nout=nout, &
10089 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10090 x=globalcorrections, istop=istop, itn=itn)
10091 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
10092 IF(icalcm == 1) THEN
10093 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
10094 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10095 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
10096 CALL equdecs(nprecond(2),nprecond(1),nprecond(3),mszpcc,lprecm,matprecond,indprecond,blockprecond,nrkd,nrkd2)
10097 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
10098 IF(monpg1 > 0) CALL monend()
10099 END IF
10100
10101 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mvsolv, nout=nout, &
10102 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10103 x=globalcorrections, istop=istop, itn=itn)
10104 ELSE
10105 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, nout=nout, &
10106 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10107 x=globalcorrections, istop=istop, itn=itn)
10108 END IF
10109
10110 !use elimination for constraints ?
10111 IF(nfgb < nvgb) THEN
10112 ! extend, transform back solution
10113 globalcorrections(nfgb+1:nvgb)=vecconssolution(1:ncgb)
10114 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10115 END IF
10116
10117 iitera=itn
10118 istopa=istop
10119 mnrsit=mnrsit+itn
10120
10121 IF (istopa == 3) print *, 'MINRES: istop=0, exact solution x=0.'
10122
10123END SUBROUTINE mminrsqlp
10124
10132
10133SUBROUTINE mcsolv(n,x,y) ! solve M*y = x
10134 USE mpmod
10135
10136 IMPLICIT NONE
10137 INTEGER(mpi),INTENT(IN) :: n
10138 REAL(mpd), INTENT(IN) :: x(n)
10139 REAL(mpd), INTENT(OUT) :: y(n)
10140 SAVE
10141 ! ...
10142 CALL presols(nprecond(1),nprecond(2),nprecond(3),mszpcc,matprecond, &
10143 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),y,x)
10144END SUBROUTINE mcsolv
10145
10153
10154SUBROUTINE mvsolv(n,x,y) ! solve M*y = x
10155 USE mpmod
10156
10157 IMPLICIT NONE
10158
10159 INTEGER(mpi), INTENT(IN) :: n
10160 REAL(mpd), INTENT(IN) :: x(n)
10161 REAL(mpd), INTENT(OUT) :: y(n)
10162
10163 SAVE
10164 ! ...
10165 y=x ! copy to output vector
10166
10167 CALL equslvs(nprecond(2),nprecond(1),nprecond(3),mszpcc,matprecond,indprecond,blockprecond,y)
10168END SUBROUTINE mvsolv
10169
10170
10171
10172!***********************************************************************
10173
10186
10187SUBROUTINE xloopn !
10188 USE mpmod
10189
10190 IMPLICIT NONE
10191 REAL(mps) :: catio
10192 REAL(mps) :: concu2
10193 REAL(mps) :: concut
10194 REAL, DIMENSION(2) :: ta
10195 REAL etime
10196 INTEGER(mpi) :: i
10197 INTEGER(mpi) :: iact
10198 INTEGER(mpi) :: iagain
10199 INTEGER(mpi) :: idx
10200 INTEGER(mpi) :: info
10201 INTEGER(mpi) :: ib
10202 INTEGER(mpi) :: ipoff
10203 INTEGER(mpi) :: icoff
10204 INTEGER(mpl) :: ioff
10205 INTEGER(mpi) :: itgbi
10206 INTEGER(mpi) :: ivgbi
10207 INTEGER(mpi) :: jcalcm
10208 INTEGER(mpi) :: k
10209 INTEGER(mpi) :: labelg
10210 INTEGER(mpi) :: litera
10211 INTEGER(mpi) :: lrej
10212 INTEGER(mpi) :: lun
10213 INTEGER(mpi) :: lunp
10214 INTEGER(mpi) :: minf
10215 INTEGER(mpi) :: mrati
10216 INTEGER(mpi) :: nan
10217 INTEGER(mpi) :: ncon
10218 INTEGER(mpi) :: nfaci
10219 INTEGER(mpi) :: nloopsol
10220 INTEGER(mpi) :: npar
10221 INTEGER(mpi) :: nrati
10222 INTEGER(mpi) :: nrej
10223 INTEGER(mpi) :: nsol
10224 INTEGER(mpi) :: inone
10225#ifdef LAPACK64
10226 INTEGER(mpi) :: infolp
10227 INTEGER(mpi) :: nfit
10228 INTEGER(mpl) :: imoff
10229#endif
10230
10231 REAL(mpd) :: stp
10232 REAL(mpd) :: dratio
10233 REAL(mpd) :: dwmean
10234 REAL(mpd) :: db
10235 REAL(mpd) :: db1
10236 REAL(mpd) :: db2
10237 REAL(mpd) :: dbdot
10238 REAL(mpd) :: dbsig
10239 LOGICAL :: btest
10240 LOGICAL :: warner
10241 LOGICAL :: warners
10242 LOGICAL :: warnerss
10243 LOGICAL :: warners3
10244 LOGICAL :: lsflag
10245 CHARACTER (LEN=7) :: cratio
10246 CHARACTER (LEN=7) :: cfacin
10247 CHARACTER (LEN=7) :: crjrat
10248 EXTERNAL avprds
10249 SAVE
10250 ! ...
10251
10252 ! Printout of algorithm for solution and important parameters ------
10253
10254 lun=lunlog ! log file
10255
10256 DO lunp=6,lunlog,lunlog-6
10257 WRITE(lunp,*) ' '
10258 WRITE(lunp,*) 'Solution algorithm: '
10259 WRITE(lunp,121) '=================================================== '
10260
10261 IF(metsol == 1) THEN
10262 WRITE(lunp,121) 'solution method:','matrix inversion'
10263 ELSE IF(metsol == 2) THEN
10264 WRITE(lunp,121) 'solution method:','diagonalization'
10265 ELSE IF(metsol == 3) THEN
10266 WRITE(lunp,121) 'solution method:','decomposition'
10267 ELSE IF(metsol == 4) THEN
10268 WRITE(lunp,121) 'solution method:', 'minres (Paige/Saunders)'
10269 ELSE IF(metsol == 5) THEN
10270 WRITE(lunp,121) 'solution method:', 'minres-qlp (Choi/Paige/Saunders)'
10271 IF(mrmode == 1) THEN
10272 WRITE(lunp,121) ' ', ' using QR factorization' ! only QR
10273 ELSE IF(mrmode == 2) THEN
10274 WRITE(lunp,121) ' ', ' using QLP factorization' ! only QLP
10275 ELSE
10276 WRITE(lunp,121) ' ', ' using QR and QLP factorization' ! QR followed by QLP
10277 WRITE(lunp,123) 'transition condition', mrtcnd
10278 END IF
10279 ELSE IF(metsol == 6) THEN
10280 WRITE(lunp,121) 'solution method:', &
10281 'gmres (generalized minimzation of residuals)'
10282#ifdef LAPACK64
10283 ELSE IF(metsol == 7) THEN
10284 IF (nagb > nvgb) THEN
10285 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSPTRF)'
10286 ELSE
10287 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPPTRF)'
10288 ENDIF
10289 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10290 ELSE IF(metsol == 8) THEN
10291 IF (nagb > nvgb) THEN
10292 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSYTRF)'
10293 ELSE
10294 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPOTRF)'
10295 ENDIF
10296 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10297#ifdef PARDISO
10298 ELSE IF(metsol == 9) THEN
10299 IF (matbsz < 2) THEN
10300 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (CSR3))'
10301 ELSE
10302 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (BSR3))'
10303 ENDIF
10304#endif
10305#endif
10306 END IF
10307 WRITE(lunp,123) 'convergence limit at Delta F=',dflim
10308 WRITE(lunp,122) 'maximum number of iterations=',mitera
10309 matrit=min(matrit,mitera)
10310 IF(matrit > 1) THEN
10311 WRITE(lunp,122) 'matrix recalculation up to ',matrit, '. iteration'
10312 END IF
10313 IF(metsol >= 4.AND.metsol < 7) THEN
10314 IF(matsto == 1) THEN
10315 WRITE(lunp,121) 'matrix storage:','full'
10316 ELSE IF(matsto == 2) THEN
10317 WRITE(lunp,121) 'matrix storage:','sparse'
10318 END IF
10319 WRITE(lunp,122) 'pre-con band-width parameter=',mbandw
10320 IF(mbandw == 0) THEN
10321 WRITE(lunp,121) 'pre-conditioning:','default'
10322 ELSE IF(mbandw < 0) THEN
10323 WRITE(lunp,121) 'pre-conditioning:','none!'
10324 ELSE IF(mbandw > 0) THEN
10325 IF(lprecm > 0) THEN
10326 WRITE(lunp,121) 'pre-conditioning=','skyline-matrix (rank preserving)'
10327 ELSE
10328 WRITE(lunp,121) 'pre-conditioning=','band-matrix'
10329 ENDIF
10330 END IF
10331 END IF
10332 IF(regpre == 0.0_mpd.AND.npresg == 0) THEN
10333 WRITE(lunp,121) 'using pre-sigmas:','no'
10334 ELSE
10335 ! FIXME: NPRESG contains parameters that failed the 'entries' cut...
10336 WRITE(lunp,124) 'pre-sigmas defined for', &
10337 REAL(100*npresg,mps)/REAL(nvgb,mps),' % of variable parameters'
10338 WRITE(lunp,123) 'default pre-sigma=',regpre
10339 END IF
10340 IF(nregul == 0) THEN
10341 WRITE(lunp,121) 'regularization:','no'
10342 ELSE
10343 WRITE(lunp,121) 'regularization:','yes'
10344 WRITE(lunp,123) 'regularization factor=',regula
10345 END IF
10346
10347 IF(chicut /= 0.0) THEN
10348 WRITE(lunp,121) 'Chi square cut equiv 3 st.dev applied'
10349 WRITE(lunp,123) '... in first iteration with factor',chicut
10350 WRITE(lunp,123) '... in second iteration with factor',chirem
10351 WRITE(lunp,121) ' (reduced by sqrt in next iterations)'
10352 END IF
10353 IF(iscerr > 0) THEN
10354 WRITE(lunp,121) 'Scaling of measurement errors applied'
10355 WRITE(lunp,123) '... factor for "global" measuements',dscerr(1)
10356 WRITE(lunp,123) '... factor for "local" measuements',dscerr(2)
10357 END IF
10358 IF(lhuber /= 0) THEN
10359 WRITE(lunp,122) 'Down-weighting of outliers in', lhuber,' iterations'
10360 WRITE(lunp,123) 'Cut on downweight fraction',dwcut
10361 END IF
10362
10363
10364121 FORMAT(1x,a40,3x,a)
10365122 FORMAT(1x,a40,3x,i0,a)
10366123 FORMAT(1x,a40,2x,e9.2)
10367124 FORMAT(1x,a40,3x,f5.1,a)
10368 END DO
10369
10370 ! initialization of iterations -------------------------------------
10371
10372 iitera=0
10373 nsol =0 ! counter for solutions
10374 info =0
10375 lsinfo=0
10376 stp =0.0_mpd
10377 stepl =real(stp,mps)
10378 concut=1.0e-12 ! initial constraint accuracy
10379 concu2=1.0e-06 ! constraint accuracy
10380 icalcm=1 ! require matrix calculation
10381 iterat=0 ! iteration counter
10382 iterat=-1
10383 litera=-2
10384 nloopsol=0 ! (new) solution from this nloopn
10385 nrej=0 ! reset number of rejects
10386 IF(metsol == 1) THEN
10387 wolfc2=0.5 ! not accurate
10388 minf=1
10389 ELSE IF(metsol == 2) THEN
10390 wolfc2=0.5 ! not acurate
10391 minf=2
10392 ELSE IF(metsol == 3) THEN
10393 wolfc2=0.5 ! not acurate
10394 minf=1
10395 ELSE IF(metsol == 4) THEN
10396 wolfc2=0.1 ! accurate
10397 minf=3
10398 ELSE IF(metsol == 5) THEN
10399 wolfc2=0.1 ! accurate
10400 minf=3
10401 ELSE IF(metsol == 6) THEN
10402 wolfc2=0.1 ! accurate
10403 minf=3
10404 ELSE
10405 wolfc2=0.5 ! not accurate
10406 minf=1
10407 END IF
10408
10409 ! check initial feasibility of constraint equations ----------------
10410
10411 WRITE(*,*) ' '
10412 IF(nofeas == 0) THEN ! make parameter feasible
10413 WRITE(lunlog,*) 'Checking feasibility of parameters:'
10414 WRITE(*,*) 'Checking feasibility of parameters:'
10415 CALL feasib(concut,iact) ! check feasibility
10416 IF(iact /= 0) THEN ! done ...
10417 WRITE(*,102) concut
10418 WRITE(*,*) ' parameters are made feasible'
10419 WRITE(lunlog,102) concut
10420 WRITE(lunlog,*) ' parameters are made feasible'
10421 ELSE ! ... was OK
10422 WRITE(*,*) ' parameters are feasible (i.e. satisfy constraints)'
10423 WRITE(lunlog,*) ' parameters are feasible (i.e. satisfy constraints)'
10424 END IF
10425 concut=concu2 ! cut for constraint check
10426 END IF
10427 iact=1 ! set flag for new data loop
10428 nofeas=0 ! set check-feasibility flag
10429
10430 WRITE(*,*) ' '
10431 WRITE(*,*)'Reading files and accumulating vectors/matrices ...'
10432 WRITE(*,*) ' '
10433 IF(monpg1>0) THEN
10434 WRITE(lunlog,*)
10435 WRITE(lunlog,*)'Reading files and accumulating vectors/matrices ...'
10436 WRITE(lunlog,*)
10437 END IF
10438
10439 rstart=etime(ta)
10440 iterat=-1
10441 litera= 0
10442 jcalcm=-1
10443 iagain= 0
10444
10445 icalcm=1
10446
10447 ! Block 1: data loop with vector (and matrix) calculation ----------
10448
10449 DO
10450 IF(iterat >= 0) THEN
10451 lcalcm=jcalcm+3 ! mode (1..4) of last loop
10452 IF(jcalcm+1 /= 0) THEN
10453 IF(iterat == 0) THEN
10454 CALL ploopa(6) ! header
10455 CALL ploopb(6)
10456 CALL ploopa(lunlog) ! iteration line
10457 CALL ploopb(lunlog)
10458 iterat=1
10459 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10460 ELSE
10461 IF(iterat /= litera) THEN
10462 CALL ploopb(6)
10463 ! CALL PLOOPA(LUNLOG)
10464 CALL ploopb(lunlog)
10465 litera=iterat
10466 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,delfun) ! fcn-value (with expected)
10467 IF(metsol == 4 .OR. metsol == 5) THEN ! extend to 6, i.e. GMRES?
10468 CALL gmpxy(2,real(iterat,mps),real(iitera,mps)) ! MINRES iterations
10469 END IF
10470 ELSE
10471 CALL ploopc(6) ! sub-iteration line
10472 CALL ploopc(lunlog)
10473 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10474 END IF
10475 END IF
10476 ELSE
10477 CALL ploopd(6) ! solution line
10478 CALL ploopd(lunlog)
10479 END IF
10480 rstart=etime(ta)
10481 ! CHK
10482 IF (iabs(jcalcm) <= 1) THEN
10483 idx=jcalcm+4
10484 times(idx )=(times(idx )*times(idx+3)+deltim) /(times(idx+3)+1.0)
10485 times(idx+3)= times(idx+3)+1.0
10486 END IF
10487 END IF
10488 jcalcm=icalcm
10489
10490 IF(icalcm >= 0) THEN ! ICALCM = +1 & 0
10491 CALL loopn ! data loop
10492 CALL addcst ! constraints
10493 lrej=nrej
10494 nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! total number of rejects
10495 IF(3*nrej > nrecal) THEN
10496 WRITE(*,*) ' '
10497 WRITE(*,*) 'Data rejected in previous loop: '
10498 WRITE(*,*) ' ', &
10499 nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', &
10500 nrejec(2), ' (huge) ',nrejec(3),' (large)'
10501 WRITE(*,*) 'Too many rejects (>33.3%) - stop'
10502 CALL peend(26,'Aborted, too many rejects')
10503 stop
10504 END IF
10505 ! fill second half (j>i) of global matrix for extended storage, experimental
10506 IF (icalcm == 1.AND.mextnd > 0) CALL mhalf2()
10507 END IF
10508 ! Block 2: new iteration with calculation of solution --------------
10509 IF(abs(icalcm) == 1) THEN ! ICALCM = +1 & -1
10510 DO i=1,nagb
10511 globalcorrections(i)=globalvector(i) ! copy rhs
10512 END DO
10513 DO i=1,nvgb
10514 itgbi=globalparvartototal(i)
10515 workspacelinesearch(i)=globalparameter(itgbi) ! copy X for line search
10516 END DO
10517
10518 iterat=iterat+1 ! increase iteration count
10519 IF(metsol == 1) THEN
10520 CALL minver ! inversion
10521 ELSE IF(metsol == 2) THEN
10522 CALL mdiags ! diagonalization
10523 ELSE IF(metsol == 3) THEN
10524 CALL mchdec ! decomposition
10525 ELSE IF(metsol == 4) THEN
10526 CALL mminrs ! MINRES
10527 ELSE IF(metsol == 5) THEN
10528 CALL mminrsqlp ! MINRES-QLP
10529 ELSE IF(metsol == 6) THEN
10530 WRITE(*,*) '... reserved for GMRES (not yet!)'
10531 CALL mminrs ! GMRES not yet
10532#ifdef LAPACK64
10533 ELSE IF(metsol == 7) THEN
10534 CALL mdptrf ! LAPACK (packed storage)
10535 ELSE IF(metsol == 8) THEN
10536 CALL mdutrf ! LAPACK (unpacked storage)
10537#ifdef PARDISO
10538 ELSE IF(metsol == 9) THEN
10539 CALL mspardiso ! Intel oneMKL PARDISO (sparse matrix (CSR3, upper triangle))
10540#endif
10541#endif
10542 END IF
10543 nloopsol=nloopn ! (new) solution for this nloopn
10544
10545 ! check feasibility and evtl. make step vector feasible
10546
10547 DO i=1,nvgb
10548 itgbi=globalparvartototal(i)
10549 globalparcopy(itgbi)=globalparameter(itgbi) ! save
10550 globalparameter(itgbi)=globalparameter(itgbi)+globalcorrections(i) ! update
10551 END DO
10552 CALL feasib(concut,iact) ! improve constraints
10553 concut=concu2 ! new cut for constraint check
10554 DO i=1,nvgb
10555 itgbi=globalparvartototal(i)
10556 globalcorrections(i)=globalparameter(itgbi)-globalparcopy(itgbi) ! feasible stp
10557 globalparameter(itgbi)=globalparcopy(itgbi) ! restore
10558 END DO
10559
10560 db=dbdot(nvgb,globalcorrections,globalvector)
10561 db1=dbdot(nvgb,globalcorrections,globalcorrections)
10562 db2=dbdot(nvgb,globalvector,globalvector)
10563 delfun=real(db,mps)
10564 angras=real(db/sqrt(db1*db2),mps)
10565 dbsig=16.0_mpd*sqrt(max(db1,db2))*epsilon(db) ! significant change
10566
10567 ! do line search for this iteration/solution ?
10568 ! lsearch >2: all, =2: all with (next) chicut =1., =1: last, <1: none
10569 lsflag=(lsearch > 2 .OR. (lsearch == 2 .AND. chicut < 2.25) .OR. &
10570 (lsearch == 1 .AND. chicut < 2.25 .AND. (delfun <= dflim .OR. iterat >= mitera)))
10571 lsflag=lsflag .AND. (db > dbsig) ! require significant change
10572 IF (lsflag) THEN
10573 ! initialize line search based on slopes and prepare next
10574 CALL ptldef(wolfc2, 10.0, minf,10)
10575 IF(metsol == 1) THEN
10576 wolfc2=0.5 ! not accurate
10577 minf=3
10578 ELSE IF(metsol == 2) THEN
10579 wolfc2=0.5 ! not acurate
10580 minf=3
10581 ELSE IF(metsol == 3) THEN
10582 wolfc2=0.5 ! not acurate
10583 minf=3
10584 ELSE IF(metsol == 4) THEN
10585 wolfc2=0.1 ! accurate
10586 minf=4
10587 ELSE IF(metsol == 5) THEN
10588 wolfc2=0.1 ! accurate
10589 minf=4
10590 ELSE IF(metsol == 6) THEN
10591 wolfc2=0.1 ! accurate
10592 minf=4
10593 ELSE
10594 wolfc2=0.5 ! not accurate
10595 minf=3
10596 END IF
10597 ENDIF
10598
10599 ! change significantly negative ?
10600 IF(db <= -dbsig) THEN
10601 WRITE(*,*) 'Function not decreasing:',db
10602 IF(db > -1.0e-3_mpd) THEN ! 100311, VB/CK: allow some margin for numerics
10603 iagain=iagain+1
10604 IF (iagain <= 1) THEN
10605 WRITE(*,*) '... again matrix calculation'
10606 icalcm=1
10607 cycle
10608 ELSE
10609 WRITE(*,*) '... aborting iterations'
10610 GO TO 90
10611 END IF
10612 ELSE
10613 WRITE(*,*) '... stopping iterations'
10614 iagain=-1
10615 GO TO 90
10616 END IF
10617 ELSE
10618 iagain=0
10619 END IF
10620 icalcm=0 ! switch
10621 ENDIF
10622 ! Block 3: line searching ------------------------------------------
10623
10624 IF(icalcm+2 == 0) EXIT
10625 IF (lsflag) THEN
10626 CALL ptline(nvgb,workspacelinesearch, & ! current parameter values
10627 flines, & ! chi^2 function value
10628 globalvector, & ! gradient
10629 globalcorrections, & ! step vector stp
10630 stp, & ! returned step factor
10631 info) ! returned information
10632 ! WRITE(*,*) 'PTLINE returns INFO, STP=',INFO, STP
10633 ELSE ! skip line search
10634 info=10
10635 stepl=1.0
10636 IF (nloopn == nloopsol) THEN ! new solution: update corrections
10637 workspacelinesearch=workspacelinesearch+globalcorrections
10638 ENDIF
10639 ENDIF
10640 lsinfo=info
10641
10642 stepl=real(stp,mps)
10643 nan=0
10644 DO i=1,nvgb
10645 itgbi=globalparvartototal(i)
10646 IF ((.NOT.(workspacelinesearch(i) <= 0.0_mpd)).AND. &
10647 (.NOT.(workspacelinesearch(i) > 0.0_mpd))) nan=nan+1
10648 globalparameter(itgbi)=workspacelinesearch(i) ! current parameter values
10649 END DO
10650
10651 IF (nan > 0) THEN
10652 WRITE(*,*) 'Result vector containes ', nan,' NaNs - stop'
10653 CALL peend(25,'Aborted, result vector contains NaNs')
10654 stop
10655 END IF
10656
10657 ! subito exit, if required -----------------------------------------
10658
10659 IF(isubit /= 0) THEN ! subito
10660 WRITE(*,*) 'Subito! Exit after first step.'
10661 GO TO 90
10662 END IF
10663
10664 IF(info == 0) THEN
10665 WRITE(*,*) 'INFO=0 should not happen (line search input err)'
10666 IF (iagain <= 0) THEN
10667 icalcm=1
10668 cycle
10669 ENDIF
10670 END IF
10671 IF(info < 0 .OR. nloopn == nloopsol) cycle
10672 ! Block 4: line search convergence ---------------------------------
10673
10674 CALL ptlprt(lunlog)
10675 CALL feasib(concut,iact) ! check constraints
10676 IF(iact /= 0.OR.chicut > 1.0) THEN
10677 icalcm=-1
10678 IF(iterat < matrit) icalcm=+1
10679 cycle ! iterate
10680 END IF
10681 IF(delfun <= dflim) GO TO 90 ! convergence
10682 IF(iterat >= mitera) GO TO 90 ! ending
10683 icalcm=-1
10684 IF(iterat < matrit) icalcm=+1
10685 cycle ! next iteration
10686
10687 ! Block 5: iteration ending ----------------------------------------
10688
1068990 icalcm=-2
10690 END DO
10691 IF(nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) /= 0) THEN
10692 WRITE(*,*) ' '
10693 WRITE(*,*) 'Data rejected in last loop: '
10694 WRITE(*,*) ' ', &
10695 nrejec(0), ' (rank deficit/NaN) ',nrejec(1),' (Ndf=0) ', &
10696 nrejec(2), ' (huge) ',nrejec(3),' (large)'
10697 END IF
10698
10699 ! monitoring of residuals
10700 IF (imonit > 0 .AND. btest(imonit,1)) CALL monres
10701 IF (lunmon > 0) CLOSE(unit=lunmon)
10702
10703 ! construct inverse from diagonalization
10704 IF(metsol == 2) CALL zdiags
10705
10706 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
10707#ifdef LAPACK64
10708 IF (metsol == 7.OR.metsol == 8) THEN
10709 ! inverse from factorization
10710 ! loop over blocks (multiple blocks only with elimination !)
10711 DO ib=1,npblck
10712 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10713 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
10714 icoff=vecparblockconoffsets(ib) ! constraint offset for block
10715 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
10716 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
10717 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
10718 IF (nfit > npar) THEN
10719 ! monitor progress
10720 IF(monpg1 > 0) THEN
10721 WRITE(lunlog,*) 'Inverse of global matrix from LDLt factorization'
10722 CALL monini(lunlog,monpg1,monpg2)
10723 END IF
10724 IF (matsto == 1) THEN
10725 !$POMP INST BEGIN(dsptri)
10726 CALL dsptri('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),workspaced,infolp)
10727 IF(infolp /= 0) print *, ' DSPTRI failed: ', infolp
10728 !$POMP INST END(dsptri)
10729 IF(monpg1 > 0) CALL monend()
10730 ELSE
10731 !$POMP INST BEGIN(dsytri)
10732 CALL dsytri('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
10733 lapackipiv(ipoff+1:),workspaced,infolp)
10734 IF(infolp /= 0) print *, ' DSYTRI failed: ', infolp
10735 !$POMP INST END(dsytri)
10736 IF(monpg1 > 0) CALL monend()
10737 END IF
10738 ELSE
10739 IF(monpg1 > 0) THEN
10740 WRITE(lunlog,*) 'Inverse of global matrix from LLt factorization'
10741 CALL monini(lunlog,monpg1,monpg2)
10742 END IF
10743 IF (matsto == 1) THEN
10744 !$POMP INST BEGIN(dpptri)
10745 CALL dpptri('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
10746 IF(infolp /= 0) print *, ' DPPTRI failed: ', infolp
10747 !$POMP INST END(dpptri)
10748 ELSE
10749 !$POMP INST BEGIN(dpotri)
10750 CALL dpotri('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
10751 IF(infolp /= 0) print *, ' DPOTRI failed: ', infolp
10752 !$POMP INST END(dpotri)
10753 END IF
10754 IF(monpg1 > 0) CALL monend()
10755 END IF
10756 END DO
10757 END IF
10758#endif
10759 !use elimination for constraints ?
10760 IF(nfgb < nvgb) THEN
10761 ! extend, transform matrix
10762 ! loop over blocks
10763 DO ib=1,npblck
10764 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10765 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
10766 icoff=vecparblockconoffsets(ib) ! constraint offset for block
10767 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
10768 DO i=npar-ncon+1,npar
10769 ioff=globalrowoffsets(i+ipoff)+ipoff
10770 globalmatd(ioff+1:ioff+i)=0.0_mpd
10771 END DO
10772 END DO
10773 ! monitor progress
10774 IF(monpg1 > 0) THEN
10775 WRITE(lunlog,*) 'Expansion of global matrix (A->Q*A*Q^t)'
10776 CALL monini(lunlog,monpg1,monpg2)
10777 END IF
10778 IF(icelim < 2) THEN
10779 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.false.) ! Q*A*Q^t
10780#ifdef LAPACK64
10781 ELSE ! unpack storage, use LAPACK
10782 CALL lpavat(.false.)
10783#endif
10784 END IF
10785 IF(monpg1 > 0) CALL monend()
10786 END IF
10787 END IF
10788
10789 dwmean=sumndf/real(ndfsum,mpd)
10790 dratio=fvalue/dwmean/real(ndfsum-nfgb,mpd)
10791 catio=real(dratio,mps)
10792 IF(nloopn /= 1.AND.lhuber /= 0) THEN
10793 catio=catio/0.9326 ! correction Huber downweighting (in global chi2)
10794 END IF
10795 mrati=nint(100.0*catio,mpi)
10796
10797 DO lunp=6,lunlog,lunlog-6
10798 WRITE(lunp,*) ' '
10799 IF (nfilw <= 0) THEN
10800 WRITE(lunp,*) 'Sum(Chi^2)/Sum(Ndf) =',fvalue
10801 WRITE(lunp,*) ' / (',ndfsum,'-',nfgb,')'
10802 WRITE(lunp,*) ' =',dratio
10803 ELSE
10804 WRITE(lunp,*) 'Sum(W*Chi^2)/Sum(Ndf)/<W> =',fvalue
10805 WRITE(lunp,*) ' / (',ndfsum,'-', nfgb,')'
10806 WRITE(lunp,*) ' /',dwmean
10807 WRITE(lunp,*) ' =',dratio
10808 END IF
10809 WRITE(lunp,*) ' '
10810 IF(nloopn /= 1.AND.lhuber /= 0) WRITE(lunp,*) &
10811 ' with correction for down-weighting ',catio
10812 END DO
10813 nrej=nrejec(0)+nrejec(1)+nrejec(2)+nrejec(3) ! total number of rejects
10814
10815 ! ... the end with exit code ???????????????????????????????????????
10816
10817 ! WRITE(*,199) ! write exit code
10818 ! + '-----------------------------------------------------------'
10819 ! IF(ITEXIT.EQ.0) WRITE(*,199)
10820 ! + 'Exit code = 0: Convergence reached'
10821 ! IF(ITEXIT.EQ.1) WRITE(*,199)
10822 ! + 'Exit code = 1: No improvement in last iteration'
10823 ! IF(ITEXIT.EQ.2) WRITE(*,199)
10824 ! + 'Exit code = 2: Maximum number of iterations reached'
10825 ! IF(ITEXIT.EQ.3) WRITE(*,199)
10826 ! + 'Exit code = 3: Failure'
10827 ! WRITE(*,199)
10828 ! + '-----------------------------------------------------------'
10829 ! WRITE(*,199) ' '
10830
10831
10832 nrati=nint(10000.0*real(nrej,mps)/real(nrecal,mps),mpi)
10833 WRITE(crjrat,197) 0.01_mpd*real(nrati,mpd)
10834 nfaci=nint(100.0*sqrt(catio),mpi)
10835
10836 WRITE(cratio,197) 0.01_mpd*real(mrati,mpd)
10837 WRITE(cfacin,197) 0.01_mpd*real(nfaci,mpd)
10838
10839 warner=.false. ! warnings
10840 IF(mrati < 90.OR.mrati > 110) warner=.true.
10841 IF(nrati > 100) warner=.true.
10842 IF(ncgbe /= 0) warner=.true.
10843 warners = .false. ! severe warnings
10844 IF(nalow /= 0) warners=.true.
10845 warnerss = .false. ! more severe warnings
10846 IF(nmiss1 /= 0) warnerss=.true.
10847 IF(iagain /= 0) warnerss=.true.
10848 IF(ndefec /= 0) warnerss=.true.
10849 IF(ndefpg /= 0) warnerss=.true.
10850 warners3 = .false. ! more severe warnings
10851 IF(nrderr /= 0) warners3=.true.
10852
10853 IF(warner.OR.warners.OR.warnerss.Or.warners3) THEN
10854 WRITE(*,199) ' '
10855 WRITE(*,199) ' '
10856 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
10857 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
10858 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
10859 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
10860 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
10861 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
10862 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
10863
10864 IF(mrati < 90.OR.mrati > 110) THEN
10865 WRITE(*,199) ' '
10866 WRITE(*,*) ' Chi^2/Ndf = ',cratio, ' (should be close to 1)'
10867 WRITE(*,*) ' => multiply all input standard ', &
10868 'deviations by factor',cfacin
10869 END IF
10870
10871 IF(nrati > 100) THEN
10872 WRITE(*,199) ' '
10873 WRITE(*,*) ' Fraction of rejects =',crjrat,' %', &
10874 ' (should be far below 1 %)'
10875 WRITE(*,*) ' => please provide correct mille data'
10876 CALL chkrej ! check (and print) rejection details
10877 END IF
10878
10879 IF(iagain /= 0) THEN
10880 WRITE(*,199) ' '
10881 WRITE(*,*) ' Matrix not positiv definite '// &
10882 '(function not decreasing)'
10883 WRITE(*,*) ' => please provide correct mille data'
10884 END IF
10885
10886 IF(ndefec /= 0) THEN
10887 WRITE(*,199) ' '
10888 WRITE(*,*) ' Rank defect =',ndefec, &
10889 ' for global matrix, should be 0'
10890 WRITE(*,*) ' => please provide correct mille data'
10891 END IF
10892
10893 IF(ndefpg /= 0) THEN
10894 WRITE(*,199) ' '
10895 WRITE(*,*) ' Rank defect for',ndefpg, &
10896 ' parameter groups, should be 0'
10897 WRITE(*,*) ' => please provide correct mille data'
10898 END IF
10899
10900 IF(nmiss1 /= 0) THEN
10901 WRITE(*,199) ' '
10902 WRITE(*,*) ' Rank defect =',nmiss1, &
10903 ' for constraint equations, should be 0'
10904 WRITE(*,*) ' => please correct constraint definition'
10905 END IF
10906
10907 IF(ncgbe /= 0) THEN
10908 WRITE(*,199) ' '
10909 WRITE(*,*) ' Number of empty constraints =',ncgbe, ', should be 0'
10910 WRITE(*,*) ' => please check constraint definition, mille data'
10911 END IF
10912
10913 IF(nxlow /= 0) THEN
10914 WRITE(*,199) ' '
10915 WRITE(*,*) ' Possible rank defects =',nxlow, ' for global matrix'
10916 WRITE(*,*) ' (too few accepted entries)'
10917 WRITE(*,*) ' => please check mille data and ENTRIES cut'
10918 END IF
10919
10920 IF(nalow /= 0) THEN
10921 WRITE(*,199) ' '
10922 WRITE(*,*) ' Possible bad elements =',nalow, ' in global vector'
10923 WRITE(*,*) ' (toos few accepted entries)'
10924 IF(ipcntr > 0) WRITE(*,*) ' (indicated in millepede.res by counts<0)'
10925 WRITE(*,*) ' => please check mille data and ENTRIES cut'
10926 END IF
10927
10928 IF(nrderr /= 0) THEN
10929 WRITE(*,199) ' '
10930 WRITE(*,*) ' Binary file(s) with read errors =',nrderr, ' (treated as EOF)'
10931 WRITE(*,*) ' => please check mille data'
10932 END IF
10933
10934 WRITE(*,199) ' '
10935 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
10936 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
10937 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
10938 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
10939 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
10940 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
10941 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
10942 WRITE(*,199) ' '
10943
10944 ENDIF
10945
10946 CALL mend ! modul ending
10947
10948 ! ------------------------------------------------------------------
10949
10950 IF(metsol == 1) THEN
10951
10952 ELSE IF(metsol == 2) THEN
10953 ! CALL zdiags moved up (before qlssq)
10954 ELSE IF(metsol == 3) THEN
10955 ! decomposition - nothing foreseen yet
10956 ELSE IF(metsol == 4 .OR. metsol == 5) THEN
10957 ! errors and correlations from MINRES
10958 DO k=1,mnrsel
10959 labelg=lbmnrs(k)
10960 IF(labelg == 0) cycle
10961 itgbi=inone(labelg)
10962 ivgbi=0
10963 IF(itgbi /= 0) ivgbi=globalparlabelindex(2,itgbi)
10964 IF(ivgbi < 0) ivgbi=0
10965 IF(ivgbi == 0) cycle
10966 ! determine error and global correlation for parameter IVGBI
10967 IF (metsol == 4) THEN
10968 CALL solglo(ivgbi)
10969 ELSE
10970 CALL solgloqlp(ivgbi)
10971 ENDIF
10972 END DO
10973
10974 ELSE IF(metsol == 6) THEN
10975
10976#ifdef LAPACK64
10977 ELSE IF(metsol == 7) THEN
10978 ! LAPACK - nothing foreseen yet
10979#endif
10980 END IF
10981
10982 CALL prtglo ! print result
10983
10984 IF (warners3) THEN
10985 CALL peend(4,'Ended with severe warnings (bad binary file(s))')
10986 ELSE IF (warnerss) THEN
10987 CALL peend(3,'Ended with severe warnings (bad global matrix)')
10988 ELSE IF (warners) THEN
10989 CALL peend(2,'Ended with severe warnings (insufficient measurements)')
10990 ELSE IF (warner) THEN
10991 CALL peend(1,'Ended with warnings (bad measurements)')
10992 ELSE
10993 CALL peend(0,'Ended normally')
10994 END IF
10995
10996102 FORMAT(' Call FEASIB with cut=',g10.3)
10997 ! 103 FORMAT(1X,A,G12.4)
10998197 FORMAT(f7.2)
10999199 FORMAT(7x,a)
11000END SUBROUTINE xloopn ! standard solution
11001
11002
11007
11008SUBROUTINE chkrej
11009 USE mpmod
11010 USE mpdalc
11011
11012 IMPLICIT NONE
11013 INTEGER(mpi) :: i
11014 INTEGER(mpi) :: kfl
11015 INTEGER(mpi) :: kmin
11016 INTEGER(mpi) :: kmax
11017 INTEGER(mpi) :: nrc
11018 INTEGER(mpi) :: nrej
11019
11020 REAL(mps) :: fmax
11021 REAL(mps) :: fmin
11022 REAL(mps) :: frac
11023
11024 REAL(mpd) :: sumallw
11025 REAL(mpd) :: sumrejw
11026
11027 sumallw=0.; sumrejw=0.;
11028 kmin=0; kmax=0;
11029 fmax=-1.; fmin=2;
11030
11031 DO i=1,nfilb
11032 kfl=kfd(2,i)
11033 nrc=-kfd(1,i)
11034 IF (nrc > 0) THEN
11035 nrej=nrc-jfd(kfl)
11036 sumallw=sumallw+real(nrc,mpd)*wfd(kfl)
11037 sumrejw=sumrejw+real(nrej,mpd)*wfd(kfl)
11038 frac=real(nrej,mps)/real(nrc,mps)
11039 IF (frac > fmax) THEN
11040 kmax=kfl
11041 fmax=frac
11042 END IF
11043 IF (frac < fmin) THEN
11044 kmin=kfl
11045 fmin=frac
11046 END IF
11047 END IF
11048 END DO
11049 IF (nfilw > 0) &
11050 WRITE(*,"(' Weighted fraction =',F8.2,' %')") 100.*sumrejw/sumallw
11051 IF (nfilb > 1) THEN
11052 WRITE(*,"(' File with max. fraction ',I6,' :',F8.2,' %')") kmax, 100.*fmax
11053 WRITE(*,"(' File with min. fraction ',I6,' :',F8.2,' %')") kmin, 100.*fmin
11054 END IF
11055
11056END SUBROUTINE chkrej
11057
11071
11072SUBROUTINE filetc
11073 USE mpmod
11074 USE mpdalc
11075
11076 IMPLICIT NONE
11077 INTEGER(mpi) :: i
11078 INTEGER(mpi) :: ia
11079 INTEGER(mpi) :: iargc
11080 INTEGER(mpi) :: ib
11081 INTEGER(mpi) :: ie
11082 INTEGER(mpi) :: ierrf
11083 INTEGER(mpi) :: ieq
11084 INTEGER(mpi) :: ifilb
11085 INTEGER(mpi) :: ioff
11086 INTEGER(mpi) :: iopt
11087 INTEGER(mpi) :: ios
11088 INTEGER(mpi) :: iosum
11089 INTEGER(mpi) :: it
11090 INTEGER(mpi) :: k
11091 INTEGER(mpi) :: mat
11092 INTEGER(mpi) :: nab
11093 INTEGER(mpi) :: nline
11094 INTEGER(mpi) :: npat
11095 INTEGER(mpi) :: ntext
11096 INTEGER(mpi) :: nu
11097 INTEGER(mpi) :: nuf
11098 INTEGER(mpi) :: nums
11099 INTEGER(mpi) :: nufile
11100 INTEGER(mpi) :: lenfileInfo
11101 INTEGER(mpi) :: lenFileNames
11102 INTEGER(mpi) :: matint
11103 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: vecfileInfo
11104 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArray
11105 INTEGER(mpl) :: rows
11106 INTEGER(mpl) :: cols
11107 INTEGER(mpl) :: newcols
11108 INTEGER(mpl) :: length
11109
11110 CHARACTER (LEN=1024) :: text
11111 CHARACTER (LEN=1024) :: fname
11112 CHARACTER (LEN=14) :: bite(3)
11113 CHARACTER (LEN=32) :: keystx
11114 INTEGER(mpi), PARAMETER :: mnum=100
11115 REAL(mpd) :: dnum(mnum)
11116
11117#ifdef READ_C_FILES
11118 INTERFACE
11119 SUBROUTINE initc(nfiles) BIND(c)
11120 USE iso_c_binding
11121 INTEGER(c_int), INTENT(IN), VALUE :: nfiles
11122 END SUBROUTINE initc
11123 END INTERFACE
11124#endif
11125
11126 SAVE
11127 DATA bite/'C_binary','text ','Fortran_binary'/
11128 ! ...
11129 CALL mstart('FILETC/X')
11130
11131 nuf=1 ! C binary is default
11132 DO i=1,8
11133 times(i)=0.0
11134 END DO
11135
11136 ! read command line options ----------------------------------------
11137
11138 filnam=' ' ! print command line options and find steering file
11139 DO i=1,iargc()
11140 IF(i == 1) THEN
11141 WRITE(*,*) ' '
11142 WRITE(*,*) 'Command line options: '
11143 WRITE(*,*) '--------------------- '
11144 END IF
11145 CALL getarg(i,text) ! get I.th text from command line
11146 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11147 WRITE(*,101) i,text(1:nab) ! echo print
11148 IF(text(ia:ia) /= '-') THEN
11149 nu=nufile(text(ia:ib)) ! inquire on file existence
11150 IF(nu == 2) THEN ! existing text file
11151 IF(filnam /= ' ') THEN
11152 WRITE(*,*) 'Second text file in command line - stop'
11153 CALL peend(12,'Aborted, second text file in command line')
11154 stop
11155 ELSE
11156 filnam=text
11157 END IF
11158 ELSE
11159 WRITE(*,*) 'Open error for file:',text(ia:ib),' - stop'
11160 CALL peend(16,'Aborted, open error for file')
11161 IF(text(ia:ia) /= '/') THEN
11162 CALL getenv('PWD',text)
11163 CALL rltext(text,ia,ib,nab)
11164 WRITE(*,*) 'PWD:',text(ia:ib)
11165 END IF
11166 stop
11167 END IF
11168 ELSE
11169 IF(index(text(ia:ib),'b') /= 0) THEN
11170 mdebug=3 ! debug flag
11171 WRITE(*,*) 'Debugging requested'
11172 END IF
11173 it=index(text(ia:ib),'t')
11174 IF(it /= 0) THEN
11175 ictest=1 ! internal test files
11176 ieq=index(text(ia+it:ib),'=')+it
11177 IF (it /= ieq) THEN
11178 IF (index(text(ia+ieq:ib),'SL0' ) /= 0) ictest=2
11179 IF (index(text(ia+ieq:ib),'SLE' ) /= 0) ictest=3
11180 IF (index(text(ia+ieq:ib),'BP' ) /= 0) ictest=4
11181 IF (index(text(ia+ieq:ib),'BRLF') /= 0) ictest=5
11182 IF (index(text(ia+ieq:ib),'BRLC') /= 0) ictest=6
11183 END IF
11184 END IF
11185 IF(index(text(ia:ib),'s') /= 0) isubit=1 ! like "subito"
11186 IF(index(text(ia:ib),'f') /= 0) iforce=1 ! like "force"
11187 IF(index(text(ia:ib),'c') /= 0) icheck=1 ! like "checkinput"
11188 IF(index(text(ia:ib),'C') /= 0) icheck=2 ! like "checkinput 2"
11189 END IF
11190 IF(i == iargc()) WRITE(*,*) '--------------------- '
11191 END DO
11192
11193
11194 ! create test files for option -t ----------------------------------
11195
11196 IF(ictest >= 1) THEN
11197 WRITE(*,*) ' '
11198 IF (ictest == 1) THEN
11199 CALL mptest ! 'wire chamber'
11200 ELSE
11201 CALL mptst2(ictest-2) ! 'silicon tracker'
11202 END IF
11203 IF(filnam == ' ') filnam='mp2str.txt'
11204 WRITE(*,*) ' '
11205 END IF
11206
11207 ! check default steering file with file-name "steerfile" -----------
11208
11209 IF(filnam == ' ') THEN ! check default steering file
11210 text='steerfile'
11211 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11212 nu=nufile(text(ia:ib)) ! inquire on file existence and type
11213 IF(nu > 0) THEN
11214 filnam=text
11215 ELSE
11216 CALL peend(10,'Aborted, no steering file')
11217 stop 'in FILETC: no steering file. .'
11218 END IF
11219 END IF
11220
11221
11222 ! open, read steering file:
11223 ! end
11224 ! fortranfiles
11225 ! cfiles
11226
11227
11228 CALL rltext(filnam,ia,ib,nfnam) ! return indices for non-blank area
11229 WRITE(*,*) ' '
11230 WRITE(*,*) 'Listing of steering file: ',filnam(1:nfnam)
11231 WRITE(*,*) '-------------------------'
11232 OPEN(10,file=filnam(1:nfnam),iostat=ios)
11233 IF(ios /= 0) THEN
11234 WRITE(*,*) 'Open error for steering file - stop'
11235 CALL peend(11,'Aborted, open error for steering file')
11236 IF(filnam(1:1) /= '/') THEN
11237 CALL getenv('PWD',text)
11238 CALL rltext(text,ia,ib,nab)
11239 WRITE(*,*) 'PWD:',text(ia:ib)
11240 END IF
11241 stop
11242 END IF
11243 ifile =0
11244 nfiles=0
11245
11246 lenfileinfo=2
11247 lenfilenames=0
11248 rows=6; cols=lenfileinfo
11249 CALL mpalloc(vecfileinfo,rows,cols,'file info from steering')
11250 nline=0
11251 DO
11252 READ(10,102,iostat=ierrf) text ! read steering file
11253 IF (ierrf < 0) EXIT ! eof
11254 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11255 nline=nline+1
11256 IF(nline <= 50) THEN ! print up to 50 lines
11257 WRITE(*,101) nline,text(1:nab)
11258 IF(nline == 50) WRITE(*,*) ' ...'
11259 END IF
11260 IF(ia == 0) cycle ! skip empty lines
11261
11262 CALL rltext(text,ia,ib,nab) ! test content 'end'
11263 IF(ib == ia+2) THEN
11264 mat=matint(text(ia:ib),'end',npat,ntext)
11265 IF(mat == max(npat,ntext)) THEN ! exact matching
11266 text=' '
11267 CALL intext(text,nline)
11268 WRITE(*,*) ' end-statement after',nline,' text lines'
11269 EXIT
11270 END IF
11271 END IF
11272
11273 keystx='fortranfiles'
11274 mat=matint(text(ia:ib),keystx,npat,ntext)
11275 IF(mat == max(npat,ntext)) THEN ! exact matching
11276 nuf=3
11277 ! WRITE(*,*) 'Fortran files'
11278 cycle
11279 END IF
11280
11281 keystx='Cfiles'
11282 mat=matint(text(ia:ib),keystx,npat,ntext)
11283 IF(mat == max(npat,ntext)) THEN ! exact matching
11284 nuf=1
11285 ! WRITE(*,*) 'Cfiles'
11286 cycle
11287 END IF
11288
11289 keystx='closeandreopen' ! don't keep binary files open
11290 mat=matint(text(ia:ib),keystx,npat,ntext)
11291 IF(mat == max(npat,ntext)) THEN ! exact matching
11292 keepopen=0
11293 cycle
11294 END IF
11295
11296 ! file names
11297 ! check for file options (' -- ')
11298 ie=ib
11299 iopt=index(text(ia:ib),' -- ')
11300 IF (iopt > 0) ie=iopt-1
11301
11302 IF(nab == 0) cycle
11303 nu=nufile(text(ia:ie)) ! inquire on file existence
11304 IF(nu > 0) THEN ! existing file
11305 IF (nfiles == lenfileinfo) THEN ! increase length
11306 CALL mpalloc(temparray,rows,cols,'temp file info from steering')
11307 temparray=vecfileinfo
11308 CALL mpdealloc(vecfileinfo)
11309 lenfileinfo=lenfileinfo*2
11310 newcols=lenfileinfo
11311 CALL mpalloc(vecfileinfo,rows,newcols,'file info from steering')
11312 vecfileinfo(:,1:cols)=temparray(:,1:cols)
11313 CALL mpdealloc(temparray)
11314 cols=newcols
11315 ENDIF
11316 nfiles=nfiles+1 ! count number of files
11317 IF(nu == 1) nu=nuf !
11318 lenfilenames=lenfilenames+ie-ia+1 ! total length of file names
11319 vecfileinfo(1,nfiles)=nline ! line number
11320 vecfileinfo(2,nfiles)=nu ! cbinary =1, text =2, fbinary=3
11321 vecfileinfo(3,nfiles)=ia ! file name start
11322 vecfileinfo(4,nfiles)=ie ! file name end
11323 vecfileinfo(5,nfiles)=iopt ! option start
11324 vecfileinfo(6,nfiles)=ib ! option end
11325 ELSE
11326 ! WRITE(*,*) 'Open error for file ',TEXT(IA:IB)
11327 ! STOP
11328 END IF
11329 END DO
11330 rewind 10
11331 ! read again to fill dynamic arrays with file info
11332 length=nfiles
11333 CALL mpalloc(mfd,length,'file type')
11334 CALL mpalloc(nfd,length,'file line (in steering)')
11335 CALL mpalloc(lfd,length,'file name length')
11336 CALL mpalloc(ofd,length,'file option')
11337 length=lenfilenames
11338 CALL mpalloc(tfd,length,'file name')
11339 nline=0
11340 i=1
11341 ioff=0
11342 DO
11343 READ(10,102,iostat=ierrf) text ! read steering file
11344 IF (ierrf < 0) EXIT ! eof
11345 nline=nline+1
11346 IF (nline == vecfileinfo(1,i)) THEN
11347 nfd(i)=vecfileinfo(1,i)
11348 mfd(i)=vecfileinfo(2,i)
11349 ia=vecfileinfo(3,i)-1
11350 lfd(i)=vecfileinfo(4,i)-ia ! length file name
11351 DO k=1,lfd(i)
11352 tfd(ioff+k)=text(ia+k:ia+k)
11353 END DO
11354 ! tfd(i)=text(vecFileInfo(3,i):vecFileInfo(4,i)) ! file name
11355 ioff=ioff+lfd(i)
11356 ofd(i)=1.0 ! option for file
11357 IF (vecfileinfo(5,i) > 0) THEN
11358 CALL ratext(text(vecfileinfo(5,i)+4:vecfileinfo(6,i)),nums,dnum,mnum) ! translate text to DP numbers
11359 IF (nums > 0) ofd(i)=real(dnum(1),mps)
11360 END IF
11361 i=i+1
11362 IF (i > nfiles) EXIT
11363 ENDIF
11364 ENDDO
11365 CALL mpdealloc(vecfileinfo)
11366 rewind 10
11367 ! additional info for binary files
11368 length=nfiles; rows=2
11369 CALL mpalloc(ifd,length,'integrated record numbers (=offset)')
11370 CALL mpalloc(jfd,length,'number of accepted records')
11371 CALL mpalloc(kfd,rows,length,'number of records in file, file order')
11372 CALL mpalloc(dfd,length,'ndf sum')
11373 CALL mpalloc(xfd,length,'max. record size')
11374 CALL mpalloc(wfd,length,'file weight')
11375 CALL mpalloc(cfd,length,'chi2 sum')
11376 CALL mpalloc(sfd,rows,length,'start, end of file name in TFD')
11377 CALL mpalloc(yfd,length,'modification date')
11378 yfd=0
11379 !
11380 WRITE(*,*) '-------------------------'
11381 WRITE(*,*) ' '
11382
11383 ! print table of files ---------------------------------------------
11384
11385 IF (mprint > 1) THEN
11386 WRITE(*,*) 'Table of files:'
11387 WRITE(*,*) '---------------'
11388 END IF
11389 WRITE(8,*) ' '
11390 WRITE(8,*) 'Text and data files:'
11391 ioff=0
11392 DO i=1,nfiles
11393 DO k=1,lfd(i)
11394 fname(k:k)=tfd(ioff+k)
11395 END DO
11396 ! fname=tfd(i)(1:lfd(i))
11397 IF (mprint > 1) WRITE(*,103) i,bite(mfd(i)),fname(1:lfd(i))
11398 WRITE(8,103) i,bite(mfd(i)),fname(1:lfd(i))
11399 ioff=ioff+lfd(i)
11400 END DO
11401 IF (mprint > 1) THEN
11402 WRITE(*,*) '---------------'
11403 WRITE(*,*) ' '
11404 END IF
11405
11406 ! open the binary Fortran (data) files on unit 11, 12, ...
11407
11408 iosum=0
11409 nfilf=0
11410 nfilb=0
11411 nfilw=0
11412 ioff=0
11413 ifilb=0
11414 IF (keepopen < 1) ifilb=1
11415 DO i=1,nfiles
11416 IF(mfd(i) == 3) THEN
11417 nfilf=nfilf+1
11418 nfilb=nfilb+1
11419 ! next file name
11420 sfd(1,nfilb)=ioff
11421 sfd(2,nfilb)=lfd(i)
11422 CALL binopn(nfilb,ifilb,ios)
11423 IF(ios == 0) THEN
11424 wfd(nfilb)=ofd(i)
11425 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11426 ELSE ! failure
11427 iosum=iosum+1
11428 nfilf=nfilf-1
11429 nfilb=nfilb-1
11430 END IF
11431 END IF
11432 ioff=ioff+lfd(i)
11433 END DO
11434
11435 ! open the binary C files
11436
11437 nfilc=-1
11438 ioff=0
11439 DO i=1,nfiles ! Cfiles
11440 IF(mfd(i) == 1) THEN
11441#ifdef READ_C_FILES
11442 IF(nfilc < 0) THEN ! initialize
11443 CALL initc(max(nfiles,mthrdr)) ! uncommented by GF
11444 nfilc=0
11445 END IF
11446 nfilc=nfilc+1
11447 nfilb=nfilb+1
11448 ! next file name
11449 sfd(1,nfilb)=ioff
11450 sfd(2,nfilb)=lfd(i)
11451 CALL binopn(nfilb,ifilb,ios)
11452 IF(ios == 0) THEN
11453 wfd(nfilb)=ofd(i)
11454 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11455 ELSE ! failure
11456 iosum=iosum+1
11457 nfilc=nfilc-1
11458 nfilb=nfilb-1
11459 END IF
11460#else
11461 WRITE(*,*) 'Opening of C-files not supported.'
11462 ! GF add
11463 iosum=iosum+1
11464 ! GF add end
11465#endif
11466 END IF
11467 ioff=ioff+lfd(i)
11468 END DO
11469
11470 DO k=1,nfilb
11471 kfd(1,k)=1 ! reset (negated) record counters
11472 kfd(2,k)=k ! set file number
11473 ifd(k)=0 ! reset integrated record numbers
11474 xfd(k)=0 ! reset max record size
11475 END DO
11476
11477 IF(iosum /= 0) THEN
11478 CALL peend(15,'Aborted, open error(s) for binary files')
11479 stop 'FILETC: open error '
11480 END IF
11481 IF(nfilb == 0) THEN
11482 CALL peend(14,'Aborted, no binary files')
11483 stop 'FILETC: no binary files '
11484 END IF
11485 IF (keepopen > 0) THEN
11486 WRITE(*,*) nfilb,' binary files opened' ! corrected by GF
11487 ELSE
11488 WRITE(*,*) nfilb,' binary files opened and closed' ! corrected by GF
11489 END IF
11490101 FORMAT(i3,2x,a)
11491102 FORMAT(a)
11492103 FORMAT(i3,2x,a14,3x,a)
11493 ! CALL mend
11494 RETURN
11495END SUBROUTINE filetc
11496
11547
11548SUBROUTINE filetx ! ---------------------------------------------------
11549 USE mpmod
11550
11551 IMPLICIT NONE
11552 INTEGER(mpi) :: i
11553 INTEGER(mpi) :: ia
11554 INTEGER(mpi) :: ib
11555 INTEGER(mpi) :: ierrf
11556 INTEGER(mpi) :: ioff
11557 INTEGER(mpi) :: ios
11558 INTEGER(mpi) :: iosum
11559 INTEGER(mpi) :: k
11560 INTEGER(mpi) :: mat
11561 INTEGER(mpi) :: nab
11562 INTEGER(mpi) :: nfiln
11563 INTEGER(mpi) :: nline
11564 INTEGER(mpi) :: nlinmx
11565 INTEGER(mpi) :: npat
11566 INTEGER(mpi) :: ntext
11567 INTEGER(mpi) :: matint
11568
11569 ! CALL MSTART('FILETX')
11570
11571 CHARACTER (LEN=1024) :: text
11572 CHARACTER (LEN=1024) :: fname
11573
11574 WRITE(*,*) ' '
11575 WRITE(*,*) 'Processing text files ...'
11576 WRITE(*,*) ' '
11577
11578 iosum=0
11579 ioff=0
11580 DO i=0,nfiles
11581 IF(i == 0) THEN
11582 WRITE(*,*) 'File ',filnam(1:nfnam)
11583 nlinmx=100
11584 ELSE
11585 nlinmx=10
11586 ia=ioff
11587 ioff=ioff+lfd(i)
11588 IF(mfd(i) /= 2) cycle ! exclude binary files
11589 DO k=1,lfd(i)
11590 fname(k:k)=tfd(ia+k)
11591 END DO
11592 WRITE(*,*) 'File ',fname(1:lfd(i))
11593 IF (mprint > 1) WRITE(*,*) ' '
11594 OPEN(10,file=fname(1:lfd(i)),iostat=ios,form='FORMATTED')
11595 IF(ios /= 0) THEN
11596 WRITE(*,*) 'Open error for file ',fname(1:lfd(i))
11597 iosum=iosum+1
11598 cycle
11599 END IF
11600 END IF
11601
11602 nline=0
11603 nfiln=1
11604 ! read text file
11605 DO
11606 READ(10,102,iostat=ierrf) text
11607 IF (ierrf < 0) THEN
11608 text=' '
11609 CALL intext(text,nline)
11610 WRITE(*,*) ' end-of-file after',nline,' text lines'
11611 EXIT ! eof
11612 ENDIF
11613 nline=nline+1
11614 IF(nline <= nlinmx.AND.mprint > 1) THEN ! print first 10 lines of every text fiLE
11615 CALL rltext(text,ia,ib,nab)
11616 nab=max(1,nab)
11617 WRITE(*,101) nline,text(1:nab)
11618 IF(nline == nlinmx) WRITE(*,*) ' ...'
11619 END IF
11620
11621 CALL rltext(text,ia,ib,nab) ! test content 'end'
11622 IF(ib == ia+2) THEN
11623 mat=matint(text(ia:ib),'end',npat,ntext)
11624 IF(mat == max(npat,ntext)) THEN ! exact matching
11625 text=' '
11626 CALL intext(text,nline)
11627 WRITE(*,*) ' end-statement after',nline,' text lines'
11628 EXIT
11629 END IF
11630 END IF
11631
11632 IF(i == 0) THEN ! first text file - exclude lines with file names
11633 IF(nfiln <= nfiles) THEN
11634 IF(nline == nfd(nfiln)) THEN
11635 nfiln=nfiln+1
11636 text=' '
11637 ! WRITE(*,*) 'line is excluded ',TEXT(1:10)
11638 END IF
11639 END IF
11640 END IF
11641 ! WRITE(*,*) TEXT(1:40),' < interprete text'
11642 CALL intext(text,nline) ! interprete text
11643 END DO
11644 WRITE(*,*) ' '
11645 rewind 10
11646 CLOSE(unit=10)
11647 END DO
11648
11649 IF(iosum /= 0) THEN
11650 CALL peend(16,'Aborted, open error(s) for text files')
11651 stop 'FILETX: open error(s) in text files '
11652 END IF
11653
11654 WRITE(*,*) '... end of text file processing.'
11655 WRITE(*,*) ' '
11656
11657 IF(lunkno /= 0) THEN
11658 WRITE(*,*) ' '
11659 WRITE(*,*) lunkno,' unknown keywords in steering files, ', &
11660 'or file non-existing,'
11661 WRITE(*,*) ' see above!'
11662 WRITE(*,*) '------------> stop'
11663 WRITE(*,*) ' '
11664 CALL peend(13,'Aborted, unknown keywords in steering file')
11665 stop
11666 END IF
11667
11668 ! check methods
11669
11670 IF(metsol == 0) THEN ! if undefined
11671 IF(matsto == 0) THEN ! if unpacked symmetric
11672 metsol=8 ! LAPACK
11673 ELSE IF(matsto == 1) THEN ! if full symmetric
11674 metsol=4 ! MINRES
11675 ELSE IF(matsto == 2) THEN ! if sparse
11676 metsol=4 ! MINRES
11677 END IF
11678 ELSE IF(metsol == 1) THEN ! if inversion
11679 matsto=1
11680 ELSE IF(metsol == 2) THEN ! if diagonalization
11681 matsto=1
11682 ELSE IF(metsol == 3) THEN ! if decomposition
11683 matsto=1
11684 ELSE IF(metsol == 4) THEN ! if MINRES
11685 ! MATSTO=2 or 1
11686 ELSE IF(metsol == 5) THEN ! if MINRES-QLP
11687 ! MATSTO=2 or 1
11688 ELSE IF(metsol == 6) THEN ! if GMRES
11689 ! MATSTO=2 or 1
11690#ifdef LAPACK64
11691 ELSE IF(metsol == 7) THEN ! if LAPACK
11692 matsto=1
11693 ELSE IF(metsol == 8) THEN ! if LAPACK
11694 matsto=0
11695#ifdef PARDISO
11696 ELSE IF(metsol == 9) THEN ! if Intel oneMKL PARDISO
11697 matsto=3
11698#endif
11699#endif
11700 ELSE
11701 WRITE(*,*) 'MINRES forced with sparse matrix!'
11702 WRITE(*,*) ' '
11703 WRITE(*,*) 'MINRES forced with sparse matrix!'
11704 WRITE(*,*) ' '
11705 WRITE(*,*) 'MINRES forced with sparse matrix!'
11706 metsol=4 ! forced
11707 matsto=2 ! forced
11708 END IF
11709 IF(matsto > 4) THEN
11710 WRITE(*,*) 'MINRES forced with sparse matrix!'
11711 WRITE(*,*) ' '
11712 WRITE(*,*) 'MINRES forced with sparse matrix!'
11713 WRITE(*,*) ' '
11714 WRITE(*,*) 'MINRES forced with sparse matrix!'
11715 metsol=4 ! forced
11716 matsto=2 ! forced
11717 END IF
11718
11719 ! print information about methods and matrix storage modes
11720
11721 WRITE(*,*) ' '
11722 WRITE(*,*) 'Solution method and matrix-storage mode:'
11723 IF(metsol == 1) THEN
11724 WRITE(*,*) ' METSOL = 1: matrix inversion'
11725 ELSE IF(metsol == 2) THEN
11726 WRITE(*,*) ' METSOL = 2: diagonalization'
11727 ELSE IF(metsol == 3) THEN
11728 WRITE(*,*) ' METSOL = 3: decomposition'
11729 ELSE IF(metsol == 4) THEN
11730 WRITE(*,*) ' METSOL = 4: MINRES'
11731 ELSE IF(metsol == 5) THEN
11732 WRITE(*,*) ' METSOL = 5: MINRES-QLP'
11733 ELSE IF(metsol == 6) THEN
11734 WRITE(*,*) ' METSOL = 6: GMRES (-> MINRES)'
11735#ifdef LAPACK64
11736 ELSE IF(metsol == 7) THEN
11737 WRITE(*,*) ' METSOL = 7: LAPACK factorization'
11738 ELSE IF(metsol == 8) THEN
11739 WRITE(*,*) ' METSOL = 8: LAPACK factorization'
11740#ifdef PARDISO
11741 ELSE IF(metsol == 9) THEN
11742 WRITE(*,*) ' METSOL = 9: Intel oneMKL PARDISO'
11743#endif
11744#endif
11745 END IF
11746
11747 WRITE(*,*) ' with',mitera,' iterations'
11748
11749 IF(matsto == 0) THEN
11750 WRITE(*,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
11751 ELSEIF(matsto == 1) THEN
11752 WRITE(*,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
11753 ELSE IF(matsto == 2) THEN
11754 WRITE(*,*) ' MATSTO = 2: sparse matrix (custom)'
11755 ELSE IF(matsto == 3) THEN
11756 IF (mpdbsz == 0) THEN
11757 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
11758 ELSE
11759 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
11760 END IF
11761 END IF
11762 IF(mbandw /= 0.AND.(metsol >= 4.AND. metsol <7)) THEN ! band matrix as MINRES preconditioner
11763 WRITE(*,*) ' and band matrix, width',mbandw
11764 END IF
11765
11766 IF(chicut /= 0.0) THEN
11767 WRITE(*,*) 'Chi square cut equiv 3 st.dev applied ...'
11768 WRITE(*,*) ' in first iteration with factor',chicut
11769 WRITE(*,*) ' in second iteration with factor',chirem
11770 WRITE(*,*) ' (reduced by sqrt in next iterations)'
11771 END IF
11772
11773 IF(lhuber /= 0) THEN
11774 WRITE(*,*) ' Down-weighting of outliers in', lhuber,' iterations'
11775 WRITE(*,*) ' Cut on downweight fraction',dwcut
11776 END IF
11777
11778 WRITE(*,*) 'Iterations (solutions) with line search:'
11779 IF(lsearch > 2) THEN
11780 WRITE(*,*) ' All'
11781 ELSEIF (lsearch == 1) THEN
11782 WRITE(*,*) ' Last'
11783 ELSEIF (lsearch < 1) THEN
11784 WRITE(*,*) ' None'
11785 ELSE
11786 IF (chicut /= 0.0) THEN
11787 WRITE(*,*) ' All with Chi square cut scaling factor <= 1.'
11788 ELSE
11789 WRITE(*,*) ' All'
11790 ENDIF
11791 ENDIF
11792
11793 IF(nummeasurements>0) THEN
11794 WRITE(*,*)
11795 WRITE(*,*) ' Number of external measurements ', nummeasurements
11796 ENDIF
11797
11798 CALL mend
11799
11800101 FORMAT(i3,2x,a)
11801102 FORMAT(a)
11802END SUBROUTINE filetx
11803
11813
11814INTEGER(mpi) FUNCTION nufile(fname)
11815 USE mpdef
11816
11817 IMPLICIT NONE
11818 INTEGER(mpi) :: ios
11819 INTEGER(mpi) :: l1
11820 INTEGER(mpi) :: ll
11821 INTEGER(mpi) :: nm
11822 INTEGER(mpi) :: npat
11823 INTEGER(mpi) :: ntext
11824 INTEGER(mpi) :: nuprae
11825 INTEGER(mpi) :: matint
11826
11827 CHARACTER (LEN=*), INTENT(INOUT) :: fname
11828 LOGICAL :: ex
11829 SAVE
11830 ! ...
11831 nufile=0
11832 nuprae=0
11833 IF(len(fname) > 5) THEN
11834 IF(fname(1:5) == 'rfio:') nuprae=1
11835 IF(fname(1:5) == 'dcap:') nuprae=2
11836 IF(fname(1:5) == 'root:') nuprae=3
11837 END IF
11838 IF(nuprae == 0) THEN
11839 INQUIRE(file=fname,iostat=ios,exist=ex)
11840 IF(ios /= 0) nufile=-abs(ios)
11841 IF(ios /= 0) RETURN
11842 ELSE IF(nuprae == 1) THEN ! rfio:
11843 ll=len(fname)
11844 fname=fname(6:ll)
11845 ex=.true.
11846 nufile=1
11847 RETURN
11848 ELSE
11849 ex=.true. ! assume file existence
11850 END IF
11851 IF(ex) THEN
11852 nufile=1 ! binary
11853 ll=len(fname)
11854 l1=max(1,ll-3)
11855 nm=matint('xt',fname(l1:ll),npat,ntext)
11856 IF(nm == 2) nufile=2 ! text
11857 IF(nm < 2) THEN
11858 nm=matint('tx',fname(l1:ll),npat,ntext)
11859 IF(nm == 2) nufile=2 ! text
11860 END IF
11861 END IF
11862END FUNCTION nufile
11863
11871SUBROUTINE intext(text,nline)
11872 USE mpmod
11873 USE mptext
11874
11875 IMPLICIT NONE
11876 INTEGER(mpi) :: i
11877 INTEGER(mpi) :: ia
11878 INTEGER(mpi) :: ib
11879 INTEGER(mpi) :: ier
11880 INTEGER(mpi) :: iomp
11881 INTEGER(mpi) :: j
11882 INTEGER(mpi) :: k
11883 INTEGER(mpi) :: kkey
11884 INTEGER(mpi) :: label
11885 INTEGER(mpi) :: lkey
11886 INTEGER(mpi) :: mat
11887 INTEGER(mpi) :: miter
11888 INTEGER(mpi) :: nab
11889 INTEGER(mpi) :: nkey
11890 INTEGER(mpi) :: nkeys
11891 INTEGER(mpi) :: nl
11892 INTEGER(mpi) :: nmeth
11893 INTEGER(mpi) :: npat
11894 INTEGER(mpi) :: ntext
11895 INTEGER(mpi) :: nums
11896 INTEGER(mpi) :: matint
11897
11898 CHARACTER (LEN=*), INTENT(IN) :: text
11899 INTEGER(mpi), INTENT(IN) :: nline
11900
11901#ifdef LAPACK64
11902#ifdef PARDISO
11903 parameter(nkeys=7,nmeth=10)
11904#else
11905 parameter(nkeys=6,nmeth=9)
11906#endif
11907#else
11908 parameter(nkeys=6,nmeth=7)
11909#endif
11910 CHARACTER (LEN=16) :: methxt(nmeth)
11911 CHARACTER (LEN=16) :: keylst(nkeys)
11912 CHARACTER (LEN=32) :: keywrd
11913 CHARACTER (LEN=32) :: keystx
11914 CHARACTER (LEN=itemCLen) :: ctext
11915 INTEGER(mpi), PARAMETER :: mnum=100
11916 REAL(mpd) :: dnum(mnum)
11917#ifdef LAPACK64
11918#ifdef PARDISO
11919 INTEGER(mpi) :: ipvs ! ... integer value
11920#endif
11921#endif
11922 INTEGER(mpi) :: lpvs ! ... integer label
11923 REAL(mpd) :: plvs ! ... float value
11924
11925 INTERFACE
11926 SUBROUTINE additem(length,list,label,value)
11927 USE mpmod
11928 INTEGER(mpi), INTENT(IN OUT) :: length
11929 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
11930 INTEGER(mpi), INTENT(IN) :: label
11931 REAL(mpd), INTENT(IN) :: value
11932 END SUBROUTINE additem
11933 SUBROUTINE additemc(length,list,label,text)
11934 USE mpmod
11935 INTEGER(mpi), INTENT(IN OUT) :: length
11936 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
11937 INTEGER(mpi), INTENT(IN) :: label
11938 CHARACTER(LEN = itemCLen), INTENT(IN) :: text
11939 END SUBROUTINE additemc
11940 SUBROUTINE additemi(length,list,label,ivalue)
11941 USE mpmod
11942 INTEGER(mpi), INTENT(IN OUT) :: length
11943 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
11944 INTEGER(mpi), INTENT(IN) :: label
11945 INTEGER(mpi), INTENT(IN) :: ivalue
11946 END SUBROUTINE additemi
11947 END INTERFACE
11948
11949 SAVE
11950#ifdef LAPACK64
11951#ifdef PARDISO
11952 DATA keylst/'unknown','parameter','constraint','measurement','method','comment','pardiso'/
11953 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
11954 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK', &
11955 'sparsePARDISO'/
11956#else
11957 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
11958 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
11959 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK'/
11960#endif
11961#else
11962 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
11963 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
11964 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition'/
11965#endif
11966 DATA lkey/-1/ ! last keyword
11967
11968 ! ...
11969 nkey=-1 ! new keyword
11970 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11971 IF(nab == 0) GOTO 10
11972 CALL ratext(text(1:nab),nums,dnum,mnum) ! translate text to DP numbers
11973
11974 IF(nums /= 0) nkey=0
11975 IF(keyb /= 0) THEN
11976 keywrd=text(keya:keyb) ! text is TEXT(KEYA)...TEXT(KEYB)
11977 ! WRITE(*,*) 'Keyword is ',KEYWRD
11978
11979 ! compare keywords
11980
11981 DO nkey=2,nkeys ! loop over all pede keywords
11982 keystx=keylst(nkey) ! copy NKEY.th pede keyword
11983 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
11984 IF(100*mat >= 80*max(npat,ntext)) GO TO 10 ! 80% (symmetric) matching
11985 END DO
11986
11987 ! more comparisons
11988
11989 keystx='print'
11990 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
11991 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
11992 mprint=1
11993 IF(nums > 0) mprint=nint(dnum(1),mpi)
11994 RETURN
11995 END IF
11996
11997 keystx='debug'
11998 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
11999 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12000 mdebug=3
12001 ! GF IF(NUMS.GT.0) MPRINT=DNUM(1)
12002 IF(nums > 0) mdebug=nint(dnum(1),mpi)
12003 IF(nums > 1) mdebg2=nint(dnum(2),mpi)
12004 RETURN
12005 END IF
12006
12007 keystx='entries'
12008 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12009 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12010 IF(nums > 0 .AND. dnum(1) > 0.5) mreqenf=nint(dnum(1),mpi)
12011 IF(nums > 1 .AND. dnum(2) > 0.5) mreqena=nint(dnum(2),mpi)
12012 IF(nums > 2 .AND. dnum(3) > 0.5) iteren=nint(dnum(1)*dnum(3),mpi)
12013 RETURN
12014 END IF
12015
12016 keystx='printrecord'
12017 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12018 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12019 IF(nums > 0) nrecpr=nint(dnum(1),mpi)
12020 IF(nums > 1) nrecp2=nint(dnum(2),mpi)
12021 RETURN
12022 END IF
12023
12024 keystx='maxrecord'
12025 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12026 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12027 IF (nums > 0.AND.dnum(1) > 0.) mxrec=nint(dnum(1),mpi)
12028 RETURN
12029 END IF
12030
12031 keystx='cache'
12032 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12033 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12034 IF (nums > 0.AND.dnum(1) >= 0.) ncache=nint(dnum(1),mpi) ! cache size, <0 keeps default
12035 IF (nums == 2.AND.dnum(2) > 0..AND.dnum(2) <= 1.0) & ! read cache fill level
12036 fcache(1)=real(dnum(2),mps)
12037 IF (nums >= 4) THEN ! explicit cache splitting
12038 DO k=1,3
12039 fcache(k)=real(dnum(k+1),mps)
12040 END DO
12041 END IF
12042 RETURN
12043 END IF
12044
12045 keystx='chisqcut'
12046 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12047 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12048 IF(nums == 0) THEN ! always 3-sigma cut
12049 chicut=1.0
12050 chirem=1.0
12051 ELSE
12052 chicut=real(dnum(1),mps)
12053 IF(chicut < 1.0) chicut=-1.0
12054 IF(nums == 1) THEN
12055 chirem=1.0 ! 3-sigma cut, if not specified
12056 ELSE
12057 chirem=real(dnum(2),mps)
12058 IF(chirem < 1.0) chirem=1.0
12059 IF(chicut >= 1.0) chirem=min(chirem,chicut)
12060 END IF
12061 END IF
12062 RETURN
12063 END IF
12064
12065 ! GF added:
12066 keystx='hugecut'
12067 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12068 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12069 IF(nums > 0) chhuge=real(dnum(1),mps)
12070 IF(chhuge < 1.0) chhuge=1.0 ! at least (!!) 3-sigma
12071 RETURN
12072 END IF
12073 ! GF added end
12074
12075 keystx='linesearch'
12076 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12077 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12078 IF(nums > 0) lsearch=nint(dnum(1),mpi)
12079 RETURN
12080 END IF
12081
12082 keystx='localfit'
12083 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12084 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12085 IF(nums > 0) lfitnp=nint(dnum(1),mpi)
12086 IF(nums > 1) lfitbb=nint(dnum(2),mpi)
12087 RETURN
12088 END IF
12089
12090 keystx='regularization'
12091 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12092 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12093 nregul=1
12094 regula=real(dnum(1),mps)
12095 IF(nums >= 2) regpre=real(dnum(2),mps)
12096 RETURN
12097 END IF
12098
12099 keystx='regularisation'
12100 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12101 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12102 nregul=1
12103 regula=real(dnum(1),mps)
12104 IF(nums >= 2) regpre=real(dnum(2),mps)
12105 RETURN
12106 END IF
12107
12108 keystx='presigma'
12109 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12110 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12111 regpre=real(dnum(1),mps)
12112 RETURN
12113 END IF
12114
12115 keystx='matiter'
12116 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12117 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12118 matrit=nint(dnum(1),mpi)
12119 RETURN
12120 END IF
12121
12122 keystx='matmoni'
12123 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12124 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12125 matmon=-1
12126 IF (nums > 0.AND.dnum(1) > 0.) matmon=nint(dnum(1),mpi)
12127 RETURN
12128 END IF
12129
12130 keystx='bandwidth'
12131 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12132 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12133 IF(nums > 0) mbandw=nint(dnum(1),mpi)
12134 IF(mbandw < 0) mbandw=-1
12135 IF(nums > 1) lprecm=nint(dnum(2),mpi)
12136 RETURN
12137 END IF
12138
12139 ! KEYSTX='outlierrejection'
12140 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12141 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12142 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12143 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12144 ! CHDFRJ=DNUM(1)
12145 ! IF(CHDFRJ.LT.3.0) CHDFRJ=100.0
12146 ! RETURN
12147 ! END IF
12148
12149 ! KEYSTX='outliersuppression'
12150 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12151 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12152 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12153 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12154 ! LHUBER=DNUM(1)
12155 ! IF(LHUBER.LE.2) LHUBER=2 ! at least 2 Huber iterations
12156 ! RETURN
12157 ! END IF
12158
12159 keystx='outlierdownweighting'
12160 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12161 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12162 lhuber=nint(dnum(1),mpi)
12163 IF(lhuber > 0.AND.lhuber <= 2) lhuber=2 ! at least 2 Huber iterations (if any)
12164 RETURN
12165 END IF
12166
12167 keystx='dwfractioncut'
12168 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12169 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12170 dwcut=real(dnum(1),mps)
12171 IF(dwcut > 0.5) dwcut=0.5
12172 RETURN
12173 END IF
12174
12175 keystx='pullrange'
12176 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12177 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12178 prange=abs(real(dnum(1),mps))
12179 RETURN
12180 END IF
12181
12182 keystx='subito'
12183 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12184 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12185 isubit=1
12186 RETURN
12187 END IF
12188
12189 keystx='force'
12190 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12191 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12192 iforce=1
12193 RETURN
12194 END IF
12195
12196 keystx='memorydebug'
12197 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12198 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12199 memdbg=1
12200 IF (nums > 0.AND.dnum(1) > 0.0) memdbg=nint(dnum(1),mpi)
12201 RETURN
12202 END IF
12203
12204 keystx='globalcorr'
12205 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12206 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12207 igcorr=1
12208 RETURN
12209 END IF
12210
12211 keystx='printcounts'
12212 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12213 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12214 ipcntr=1
12215 IF (nums > 0.AND.dnum(1) > 0.0) ipcntr=nint(dnum(1),mpi)
12216 RETURN
12217 END IF
12218
12219 keystx='weightedcons'
12220 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12221 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12222 iwcons=1
12223 IF (nums > 0) iwcons=nint(dnum(1),mpi)
12224 RETURN
12225 END IF
12226
12227 keystx='skipemptycons'
12228 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12229 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12230 iskpec=1
12231 RETURN
12232 END IF
12233
12234 keystx='resolveredundancycons'
12235 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12236 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12237 irslvrc=1
12238 RETURN
12239 END IF
12240
12241 keystx='withelimination'
12242 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12243 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12244 icelim=1
12245 RETURN
12246 END IF
12247
12248#ifdef LAPACK64
12249 keystx='withLAPACKelimination'
12250 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12251 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12252 icelim=2
12253 RETURN
12254 END IF
12255#endif
12256
12257 keystx='withmultipliers'
12258 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12259 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12260 icelim=0
12261 RETURN
12262 END IF
12263
12264 keystx='checkinput'
12265 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12266 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12267 icheck=1
12268 IF (nums > 0) icheck=nint(dnum(1),mpi)
12269 RETURN
12270 END IF
12271
12272 keystx='checkparametergroups'
12273 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12274 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12275 ichkpg=1
12276 RETURN
12277 END IF
12278
12279 keystx='monitorresiduals'
12280 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12281 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12282 imonit=3
12283 IF (nums > 0) imonit=nint(dnum(1),mpi)
12284 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12285 RETURN
12286 END IF
12287
12288 keystx='monitorpulls'
12289 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12290 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12291 imonit=3
12292 imonmd=1
12293 IF (nums > 0) imonit=nint(dnum(1),mpi)
12294 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12295 RETURN
12296 END IF
12297
12298 keystx='monitorprogress'
12299 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12300 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12301 monpg1=1
12302 monpg2=1024
12303 IF (nums > 0) monpg1=max(1,nint(dnum(1),mpi))
12304 IF (nums > 1) monpg2=max(1,nint(dnum(2),mpi))
12305 RETURN
12306 END IF
12307
12308 keystx='scaleerrors'
12309 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12310 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12311 iscerr=1
12312 IF (nums > 0) dscerr(1:2)=dnum(1)
12313 IF (nums > 1) dscerr(2)=dnum(2)
12314 RETURN
12315 END IF
12316
12317 keystx='iterateentries'
12318 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12319 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12320 iteren=huge(iteren)
12321 IF (nums > 0) iteren=nint(dnum(1),mpi)
12322 RETURN
12323 END IF
12324
12325 keystx='threads'
12326 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12327 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12328 iomp=0
12329 !$ IOMP=1
12330 !$ IF (IOMP.GT.0) THEN
12331 !$ IF (NUMS.GE.1.AND.DNUM(1).GT.0.) MTHRD =NINT(dnum(1),mpi)
12332 !$ MTHRDR=MTHRD
12333 !$ IF (NUMS.GE.2.AND.DNUM(2).GT.0.) MTHRDR=NINT(dnum(2),mpi)
12334 !$ ELSE
12335 WRITE(*,*) 'WARNING: multithreading not available'
12336 !$ ENDIF
12337 RETURN
12338 END IF
12339
12340 keystx='compress'
12341 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12342 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12343 WRITE(*,*) 'WARNING: keyword COMPRESS is obsolete (compression is default)'
12344 RETURN
12345 END IF
12346
12347 ! still experimental
12348 !keystx='extendedStorage'
12349 !mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12350 !IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12351 ! mextnd=1
12352 ! RETURN
12353 !END IF
12354
12355 keystx='countrecords'
12356 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12357 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12358 mcount=1
12359 RETURN
12360 END IF
12361
12362 keystx='errlabels'
12363 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12364 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12365 nl=min(nums,100-mnrsel)
12366 DO k=1,nl
12367 lbmnrs(mnrsel+k)=nint(dnum(k),mpi)
12368 END DO
12369 mnrsel=mnrsel+nl
12370 RETURN
12371 END IF
12372
12373 keystx='pairentries'
12374 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12375 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12376 ! This option could be implemented to get rid of parameter pairs
12377 ! that have very few entries - to save matrix memory size.
12378 IF (nums > 0.AND.dnum(1) > 0.0) THEN
12379 mreqpe=nint(dnum(1),mpi)
12380 IF (nums >= 2.AND.dnum(2) >= dnum(1)) mhispe=nint(dnum(2),mpi)
12381 IF (nums >= 3.AND.dnum(3) >= dnum(1)) msngpe=nint(dnum(3),mpi)
12382 END IF
12383 RETURN
12384 END IF
12385
12386 keystx='wolfe'
12387 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12388 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12389 wolfc1=real(dnum(1),mps)
12390 wolfc2=real(dnum(2),mps)
12391 RETURN
12392 END IF
12393
12394 ! GF added:
12395 ! convergence tolerance for minres:
12396 keystx='mrestol'
12397 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12398 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12399 IF(nums > 0) THEN
12400 IF (dnum(1) < 1.0e-10_mpd.OR.dnum(1) > 1.0e-04_mpd) THEN
12401 WRITE(*,*) 'ERROR: need 1.0D-10 <= MRESTL ', &
12402 '<= 1.0D-04, but get ', dnum(1)
12403 ELSE
12404 mrestl=dnum(1)
12405 END IF
12406 END IF
12407 RETURN
12408 END IF
12409 ! GF added end
12410
12411 keystx='mrestranscond'
12412 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12413 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12414 IF(nums > 0) THEN
12415 mrtcnd = dnum(1)
12416 END IF
12417 RETURN
12418 END IF
12419
12420 keystx='mresmode'
12421 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12422 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12423 IF(nums > 0) THEN
12424 mrmode = int(dnum(1),mpi)
12425 END IF
12426 RETURN
12427 END IF
12428
12429 keystx='nofeasiblestart'
12430 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12431 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12432 nofeas=1 ! do not make parameters feasible at start
12433 RETURN
12434 END IF
12435
12436 keystx='histprint'
12437 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12438 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12439 nhistp=1 ! print histograms
12440 RETURN
12441 END IF
12442
12443 keystx='readerroraseof' ! treat (C) read errors as eof
12444 mat=matint(text(ia:ib),keystx,npat,ntext)
12445 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12446 ireeof=1
12447 RETURN
12448 END IF
12449
12450#ifdef LAPACK64
12451 keystx='LAPACKwitherrors' ! calculate parameter errors with LAPACK
12452 mat=matint(text(ia:ib),keystx,npat,ntext)
12453 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12454 ilperr=1
12455 RETURN
12456 END IF
12457#ifdef PARDISO
12458 keystx='debugPARDISO' ! enable debug for Intel oneMKL PARDISO
12459 mat=matint(text(ia:ib),keystx,npat,ntext)
12460 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12461 ipddbg=1
12462 RETURN
12463 END IF
12464
12465 keystx='blocksizePARDISO' ! use BSR3 for Intel oneMKL PARDISO, list of (increasing) block sizes to be tried
12466 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12467 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12468 nl=min(nums,10-mpdbsz)
12469 DO k=1,nl
12470 IF (nint(dnum(k),mpi) > 0) THEN
12471 IF (mpdbsz == 0) THEN
12472 mpdbsz=mpdbsz+1
12473 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12474 ELSE IF (nint(dnum(k),mpi) > ipdbsz(mpdbsz)) THEN
12475 mpdbsz=mpdbsz+1
12476 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12477 END IF
12478 END IF
12479 END DO
12480 RETURN
12481 END IF
12482#endif
12483#endif
12484 keystx='fortranfiles'
12485 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12486 IF(mat == max(npat,ntext)) RETURN
12487
12488 keystx='Cfiles'
12489 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12490 IF(mat == max(npat,ntext)) RETURN
12491
12492 keystx='closeandreopen'
12493 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12494 IF(mat == max(npat,ntext)) RETURN
12495
12496 keystx=keylst(1)
12497 nkey=1 ! unknown keyword
12498 IF(nums /= 0) nkey=0
12499
12500 WRITE(*,*) ' '
12501 WRITE(*,*) '**************************************************'
12502 WRITE(*,*) ' '
12503 WRITE(*,*) 'Unknown keyword(s): ',text(1:min(nab,50))
12504 WRITE(*,*) ' '
12505 WRITE(*,*) '**************************************************'
12506 WRITE(*,*) ' '
12507 lunkno=lunkno+1
12508
12509 END IF
12510 ! result: NKEY = -1 blank
12511 ! NKEY = 0 numerical data, no text keyword or unknown
12512 ! NKEY > 0 keyword NKEY from list, keyword = KEYSTX
12513
12514
12515 ! content/lastcontent
12516 ! -------------------
12517 ! blank -1
12518 ! data 0
12519 ! keyword
12520 ! unknown 1
12521 ! parameter 2
12522 ! constraint 3
12523 ! measurement 4
12524 ! method 5
12525
12526
1252710 IF(nkey > 0) THEN ! new keyword
12528 lkey=nkey
12529 IF(lkey == 2) THEN ! parameter
12530 IF(nums == 3) THEN
12531 lpvs=nint(dnum(1),mpi) ! label
12532 IF(lpvs /= 0) THEN
12533 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12534 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12535 ELSE
12536 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12537 END IF
12538 ELSE IF(nums /= 0) THEN
12539 kkey=1 ! switch to "unknown" ?
12540 WRITE(*,*) 'Wrong text in line',nline
12541 WRITE(*,*) 'Status: new parameter'
12542 WRITE(*,*) '> ',text(1:nab)
12543 END IF
12544 ELSE IF(lkey == 3) THEN ! constraint
12545 ! WRITE(*,*) 'Keyword is constraint!',NUMS,' numerical data'
12546 IF(nums >= 1.AND.nums <= 2) THEN ! start constraint
12547 lpvs=-nline ! r = r.h.s. value
12548 CALL additem(lenconstraints,listconstraints,lpvs,dnum(1))
12549 lpvs=-1 ! constraint
12550 IF(iwcons > 0) lpvs=-2 ! weighted constraint
12551 plvs=0.0
12552 IF(nums == 2) plvs=dnum(2) ! sigma
12553 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12554 ELSE
12555 kkey=1 ! switch to "unknown"
12556 WRITE(*,*) 'Wrong text in line',nline
12557 WRITE(*,*) 'Status: new keyword constraint'
12558 WRITE(*,*) '> ',text(1:nab)
12559 END IF
12560 ELSE IF(lkey == 4) THEN ! measurement
12561 IF(nums == 2) THEN ! start measurement
12562 nummeasurements=nummeasurements+1
12563 lpvs=-nline ! r = r.h.s. value
12564 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(1))
12565 lpvs=-1 ! sigma
12566 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(2))
12567 ELSE
12568 kkey=1 ! switch to "unknown"
12569 WRITE(*,*) 'Wrong text in line',nline
12570 WRITE(*,*) 'Status: new keyword measurement'
12571 WRITE(*,*) '> ',text(1:nab)
12572 END IF
12573 ELSE IF(lkey == 5.AND.keyb < keyc) THEN ! method with text argument
12574 miter=mitera
12575 IF(nums >= 1) miter=nint(dnum(1),mpi)
12576 IF(miter >= 1) mitera=miter
12577 dflim=real(dnum(2),mps)
12578 lkey=0
12579 DO i=1,nmeth
12580 keystx=methxt(i)
12581 mat=matint(text(keyb+1:keyc),keystx,npat,ntext) ! comparison
12582 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12583 IF(i == 1) THEN ! diagonalization
12584 metsol=2
12585 matsto=1
12586 ELSE IF(i == 2) THEN ! inversion
12587 metsol=1
12588 matsto=1
12589 ELSE IF(i == 3) THEN ! fullMINRES
12590 metsol=4
12591 matsto=1
12592 ELSE IF(i == 4) THEN ! sparseMINRES
12593 metsol=4
12594 matsto=2
12595 ELSE IF(i == 5) THEN ! fullMINRES-QLP
12596 metsol=5
12597 matsto=1
12598 ELSE IF(i == 6) THEN ! sparseMINRES-QLP
12599 metsol=5
12600 matsto=2
12601 ELSE IF(i == 7) THEN ! decomposition
12602 metsol=3
12603 matsto=1
12604#ifdef LAPACK64
12605 ELSE IF(i == 8) THEN ! fullLAPACK factorization
12606 metsol=7
12607 matsto=1
12608 ELSE IF(i == 9) THEN ! unpackedLAPACK factorization
12609 metsol=8
12610 matsto=0
12611#ifdef PARDISO
12612 ELSE IF(i == 10) THEN ! Intel oneMKL PARDISO (sparse matrix (CSR3 or BSR3, upper triangle))
12613 metsol=9
12614 matsto=3
12615#endif
12616#endif
12617 END IF
12618 END IF
12619 END DO
12620 END IF
12621 ELSE IF(nkey == 0) THEN ! data for continuation
12622 IF(lkey == 2) THEN ! parameter
12623 IF(nums >= 3) THEN ! store data from this line
12624 lpvs=nint(dnum(1),mpi) ! label
12625 IF(lpvs /= 0) THEN
12626 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12627 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12628 ELSE
12629 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12630 END IF
12631 ELSE IF(nums > 1.AND.nums < 3) THEN
12632 kkey=1 ! switch to "unknown" ?
12633 WRITE(*,*) 'Wrong text in line',nline
12634 WRITE(*,*) 'Status continuation parameter'
12635 WRITE(*,*) '> ',text(1:nab)
12636 END IF
12637
12638 ELSE IF(lkey == 3) THEN ! constraint
12639 ier=0
12640 DO i=1,nums,2
12641 label=nint(dnum(i),mpi)
12642 IF(label <= 0) ier=1
12643 END DO
12644 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12645 IF(ier == 0) THEN
12646 DO i=1,nums,2
12647 lpvs=nint(dnum(i),mpi) ! label
12648 plvs=dnum(i+1) ! factor
12649 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12650 END DO
12651 ELSE
12652 kkey=0
12653 WRITE(*,*) 'Wrong text in line',nline
12654 WRITE(*,*) 'Status continuation constraint'
12655 WRITE(*,*) '> ',text(1:nab)
12656 END IF
12657
12658 ELSE IF(lkey == 4) THEN ! measurement
12659 ! WRITE(*,*) 'continuation < ',NUMS
12660 ier=0
12661 DO i=1,nums,2
12662 label=nint(dnum(i),mpi)
12663 IF(label <= 0) ier=1
12664 END DO
12665 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12666 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12667 IF(ier == 0) THEN
12668 DO i=1,nums,2
12669 lpvs=nint(dnum(i),mpi) ! label
12670 plvs=dnum(i+1) ! factor
12671 CALL additem(lenmeasurements,listmeasurements,lpvs,plvs)
12672 END DO
12673 ELSE
12674 kkey=0
12675 WRITE(*,*) 'Wrong text in line',nline
12676 WRITE(*,*) 'Status continuation measurement'
12677 WRITE(*,*) '> ',text(1:nab)
12678 END IF
12679 ELSE IF(lkey == 6) THEN ! comment
12680 IF(nums == 1) THEN
12681 lpvs=nint(dnum(1),mpi) ! label
12682 IF(lpvs /= 0) THEN
12683 ! skip label
12684 DO j=ia,ib
12685 IF (text(j:j) == ' ') EXIT
12686 END DO
12687 ctext=text(j:ib)
12688 CALL additemc(lencomments,listcomments,lpvs,ctext)
12689 ELSE
12690 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12691 END IF
12692 ELSE IF(nums /= 0) THEN
12693 kkey=1 ! switch to "unknown"
12694 WRITE(*,*) 'Wrong text in line',nline
12695 WRITE(*,*) 'Status: continuation comment'
12696 WRITE(*,*) '> ',text(1:nab)
12697 END IF
12698#ifdef LAPACK64
12699#ifdef PARDISO
12700 ELSE IF(lkey == 7) THEN ! Intel oneMKL PARDISO parameters
12701 ier=0
12702 DO i=1,nums,2
12703 label=nint(dnum(i),mpi)
12704 IF(label <= 0.OR.label > 64) ier=1
12705 END DO
12706 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12707 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12708 IF(ier == 0) THEN
12709 DO i=1,nums,2
12710 lpvs=nint(dnum(i),mpi) ! label
12711 ipvs=nint(dnum(i+1),mpi) ! parameter
12712 CALL additemi(lenpardiso,listpardiso,lpvs,ipvs)
12713 END DO
12714 ELSE
12715 kkey=0
12716 WRITE(*,*) 'Wrong text in line',nline
12717 WRITE(*,*) 'Status continuation measurement'
12718 WRITE(*,*) '> ',text(1:nab)
12719 END IF
12720#endif
12721#endif
12722 END IF
12723 END IF
12724END SUBROUTINE intext
12725
12733SUBROUTINE additem(length,list,label,value)
12734 USE mpdef
12735 USE mpdalc
12736
12737 INTEGER(mpi), INTENT(IN OUT) :: length
12738 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12739 INTEGER(mpi), INTENT(IN) :: label
12740 REAL(mpd), INTENT(IN) :: value
12741
12742 INTEGER(mpl) :: newSize
12743 INTEGER(mpl) :: oldSize
12744 TYPE(listitem), DIMENSION(:), ALLOCATABLE :: tempList
12745
12746 IF (label > 0.AND.value == 0.) RETURN ! skip zero for valid labels
12747 IF (length == 0 ) THEN ! initial list with size = 100
12748 newsize = 100
12749 CALL mpalloc(list,newsize,' list ')
12750 ENDIF
12751 oldsize=size(list,kind=mpl)
12752 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
12753 newsize = oldsize + oldsize/5 + 100
12754 CALL mpalloc(templist,oldsize,' temp. list ')
12755 templist=list
12756 CALL mpdealloc(list)
12757 CALL mpalloc(list,newsize,' list ')
12758 list(1:oldsize)=templist(1:oldsize)
12759 CALL mpdealloc(templist)
12760 ENDIF
12761 ! add to end of list
12762 length=length+1
12763 list(length)%label=label
12764 list(length)%value=value
12765
12766END SUBROUTINE additem
12767
12775SUBROUTINE additemc(length,list,label,text)
12776 USE mpdef
12777 USE mpdalc
12778
12779 INTEGER(mpi), INTENT(IN OUT) :: length
12780 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12781 INTEGER(mpi), INTENT(IN) :: label
12782 CHARACTER(len = itemCLen), INTENT(IN) :: text
12783
12784 INTEGER(mpl) :: newSize
12785 INTEGER(mpl) :: oldSize
12786 TYPE(listitemc), DIMENSION(:), ALLOCATABLE :: tempList
12787
12788 IF (label > 0.AND.text == '') RETURN ! skip empty text for valid labels
12789 IF (length == 0 ) THEN ! initial list with size = 100
12790 newsize = 100
12791 CALL mpalloc(list,newsize,' list ')
12792 ENDIF
12793 oldsize=size(list,kind=mpl)
12794 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
12795 newsize = oldsize + oldsize/5 + 100
12796 CALL mpalloc(templist,oldsize,' temp. list ')
12797 templist=list
12798 CALL mpdealloc(list)
12799 CALL mpalloc(list,newsize,' list ')
12800 list(1:oldsize)=templist(1:oldsize)
12801 CALL mpdealloc(templist)
12802 ENDIF
12803 ! add to end of list
12804 length=length+1
12805 list(length)%label=label
12806 list(length)%text=text
12807
12808END SUBROUTINE additemc
12809
12817SUBROUTINE additemi(length,list,label,ivalue)
12818 USE mpdef
12819 USE mpdalc
12820
12821 INTEGER(mpi), INTENT(IN OUT) :: length
12822 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12823 INTEGER(mpi), INTENT(IN) :: label
12824 INTEGER(mpi), INTENT(IN) :: ivalue
12825
12826 INTEGER(mpl) :: newSize
12827 INTEGER(mpl) :: oldSize
12828 TYPE(listitemi), DIMENSION(:), ALLOCATABLE :: tempList
12829
12830 IF (length == 0 ) THEN ! initial list with size = 100
12831 newsize = 100
12832 CALL mpalloc(list,newsize,' list ')
12833 ENDIF
12834 oldsize=size(list,kind=mpl)
12835 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
12836 newsize = oldsize + oldsize/5 + 100
12837 CALL mpalloc(templist,oldsize,' temp. list ')
12838 templist=list
12839 CALL mpdealloc(list)
12840 CALL mpalloc(list,newsize,' list ')
12841 list(1:oldsize)=templist(1:oldsize)
12842 CALL mpdealloc(templist)
12843 ENDIF
12844 ! add to end of list
12845 length=length+1
12846 list(length)%label=label
12847 list(length)%ivalue=ivalue
12848
12849END SUBROUTINE additemi
12850
12852SUBROUTINE mstart(text)
12853 USE mpdef
12854 USE mpmod, ONLY: textl
12855
12856 IMPLICIT NONE
12857 INTEGER(mpi) :: i
12858 INTEGER(mpi) :: ka
12859 INTEGER(mpi) :: kb
12860 INTEGER(mpi) :: l
12861 CHARACTER (LEN=*), INTENT(IN) :: text
12862 CHARACTER (LEN=16) :: textc
12863 SAVE
12864 ! ...
12865 DO i=1,74
12866 textl(i:i)='_'
12867 END DO
12868 l=len(text)
12869 ka=(74-l)/2
12870 kb=ka+l-1
12871 textl(ka:kb)=text(1:l)
12872 WRITE(*,*) ' '
12873 WRITE(*,*) textl
12874 WRITE(*,*) ' '
12875 textc=text(1:l)//'-end'
12876
12877 DO i=1,74
12878 textl(i:i)='_'
12879 END DO
12880 l=l+4
12881 ka=(74-l)/2
12882 kb=ka+l-1
12883 textl(ka:kb)=textc(1:l)
12884 RETURN
12885END SUBROUTINE mstart
12886
12888SUBROUTINE mend
12889 USE mpmod, ONLY: textl
12890
12891 IMPLICIT NONE
12892 WRITE(*,*) ' '
12893 WRITE(*,*) textl
12894 CALL petime
12895 WRITE(*,*) ' '
12896END SUBROUTINE mend
12897
12904
12905SUBROUTINE mvopen(lun,fname)
12906 USE mpdef
12907
12908 IMPLICIT NONE
12909 INTEGER(mpi) :: l
12910 INTEGER(mpi), INTENT(IN) :: lun
12911 CHARACTER (LEN=*), INTENT(IN) :: fname
12912 CHARACTER (LEN=33) :: nafile
12913 CHARACTER (LEN=33) :: nbfile
12914 LOGICAL :: ex
12915 SAVE
12916 ! ...
12917 l=len(fname)
12918 IF(l > 32) THEN
12919 CALL peend(17,'Aborted, file name too long')
12920 stop 'File name too long '
12921 END IF
12922 nafile=fname
12923 nafile(l+1:l+1)='~'
12924
12925 INQUIRE(file=nafile(1:l),exist=ex)
12926 IF(ex) THEN
12927 INQUIRE(file=nafile(1:l+1),exist=ex)
12928 IF(ex) THEN
12929 CALL system('rm '//nafile)
12930 END IF
12931 nbfile=nafile
12932 nafile(l+1:l+1)=' '
12933 CALL system('mv '//nafile//nbfile)
12934 END IF
12935 OPEN(unit=lun,file=fname)
12936END SUBROUTINE mvopen
12937
12941
12942SUBROUTINE petime
12943 USE mpdef
12944
12945 IMPLICIT NONE
12946 REAL, DIMENSION(2) :: ta
12947 REAL etime
12948 REAL :: rst
12949 REAL :: delta
12950 REAL :: rstp
12951 REAL :: secnd1
12952 REAL :: secnd2
12953 INTEGER :: ncount
12954 INTEGER :: nhour1
12955 INTEGER :: minut1
12956 INTEGER :: nsecd1
12957 INTEGER :: nhour2
12958 INTEGER :: minut2
12959 INTEGER :: nsecd2
12960
12961 SAVE
12962 DATA ncount/0/
12963 ! ...
12964 ncount=ncount+1
12965 rst=etime(ta)
12966 IF(ncount > 1) THEN
12967 delta=rst
12968 nsecd1=int(delta,mpi) ! -> integer
12969 nhour1=nsecd1/3600
12970 minut1=nsecd1/60-60*nhour1
12971 secnd1=delta-60*(minut1+60*nhour1)
12972 delta=rst-rstp
12973 nsecd2=int(delta,mpi) ! -> integer
12974 nhour2=nsecd2/3600
12975 minut2=nsecd2/60-60*nhour2
12976 secnd2=delta-60*(minut2+60*nhour2)
12977 WRITE(*,101) nhour1,minut1,secnd1, nhour2,minut2,secnd2
12978 END IF
12979
12980 rstp=rst
12981 RETURN
12982101 FORMAT(i4,' h',i3,' min',f5.1,' sec total',18x,'elapsed', &
12983 i4,' h',i3,' min',f5.1,' sec')
12984END SUBROUTINE petime ! print
12985
12992
12993SUBROUTINE peend(icode, cmessage)
12994 USE mpdef
12995
12996 IMPLICIT NONE
12997 INTEGER(mpi), INTENT(IN) :: icode
12998 CHARACTER (LEN=*), INTENT(IN) :: cmessage
12999
13000 CALL mvopen(9,'millepede.end')
13001 WRITE(9,101) icode, cmessage
13002101 FORMAT(1x,i4,3x,a)
13003 CLOSE(9)
13004 RETURN
13005
13006END SUBROUTINE peend
13007
13014SUBROUTINE binopn(kfile, ithr, ierr)
13015 USE mpmod
13016
13017 IMPLICIT NONE
13018 INTEGER(mpi), INTENT(IN) :: kfile
13019 INTEGER(mpi), INTENT(IN) :: ithr
13020 INTEGER(mpi), INTENT(OUT) :: ierr
13021
13022 INTEGER(mpi), DIMENSION(13) :: ibuff
13023 INTEGER(mpi) :: ioff
13024 INTEGER(mpi) :: ios
13025 INTEGER(mpi) :: k
13026 INTEGER(mpi) :: lfn
13027 INTEGER(mpi) :: lun
13028 INTEGER(mpi) :: moddate
13029 CHARACTER (LEN=1024) :: fname
13030 CHARACTER (LEN=7) :: cfile
13031 INTEGER stat
13032
13033#ifdef READ_C_FILES
13034 INTERFACE
13035 SUBROUTINE openc(filename, lfn, lun, ios) BIND(c)
13036 USE iso_c_binding
13037 CHARACTER(kind=c_char), DIMENSION(*), INTENT(IN) :: filename
13038 INTEGER(c_int), INTENT(IN), VALUE :: lfn
13039 INTEGER(c_int), INTENT(IN), VALUE :: lun
13040 INTEGER(c_int), INTENT(INOUT) :: ios
13041 END SUBROUTINE openc
13042 END INTERFACE
13043#endif
13044
13045 ierr=0
13046 lun=ithr
13047 ! modification date (=0: open for first time, >0: reopen, <0: unknown )
13048 moddate=yfd(kfile)
13049 ! file name
13050 ioff=sfd(1,kfile)
13051 lfn=sfd(2,kfile)
13052 DO k=1,lfn
13053 fname(k:k)=tfd(ioff+k)
13054 END DO
13055 !print *, " opening binary ", kfile, ithr, moddate, " : ", fname(1:lfn)
13056 ! open
13057 ios=0
13058 IF(kfile <= nfilf) THEN
13059 ! Fortran file
13060 lun=kfile+10
13061 OPEN(lun,file=fname(1:lfn),iostat=ios, form='UNFORMATTED')
13062 print *, ' lun ', lun, ios
13063#ifdef READ_C_FILES
13064 ELSE
13065 ! C file
13066 CALL openc(fname(1:lfn),lfn,lun,ios)
13067#else
13068 WRITE(*,*) 'Opening of C-files not supported.'
13069 ierr=1
13070 RETURN
13071#endif
13072 END IF
13073 IF(ios /= 0) THEN
13074 ierr=1
13075 WRITE(*,*) 'Open error for file ',fname(1:lfn), ios
13076 IF (moddate /= 0) THEN
13077 WRITE(cfile,'(I7)') kfile
13078 CALL peend(15,'Aborted, open error(s) for binary file ' // cfile)
13079 stop 'PEREAD: open error'
13080 ENDIF
13081 RETURN
13082 END IF
13083 ! get status
13084 ios=stat(fname(1:lfn),ibuff)
13085 !print *, ' STAT ', ios, ibuff(10), moddate
13086 IF(ios /= 0) THEN
13087 ierr=1
13088 WRITE(*,*) 'STAT error for file ',fname(1:lfn), ios
13089 ibuff(10)=-1
13090 END IF
13091 ! check/store modification date
13092 IF (moddate /= 0) THEN
13093 IF (ibuff(10) /= moddate) THEN
13094 WRITE(cfile,'(I7)') kfile
13095 CALL peend(19,'Aborted, binary file modified (date) ' // cfile)
13096 stop 'PEREAD: file modified'
13097 END IF
13098 ELSE
13099 yfd(kfile)=ibuff(10)
13100 END IF
13101 RETURN
13102
13103END SUBROUTINE binopn
13104
13110SUBROUTINE bincls(kfile, ithr)
13111 USE mpmod
13112
13113 IMPLICIT NONE
13114 INTEGER(mpi), INTENT(IN) :: kfile
13115 INTEGER(mpi), INTENT(IN) :: ithr
13116
13117 INTEGER(mpi) :: lun
13118
13119#ifdef READ_C_FILES
13120 INTERFACE
13121 SUBROUTINE closec(lun) BIND(c)
13122 USE iso_c_binding
13123 INTEGER(c_int), INTENT(IN), VALUE :: lun
13124 END SUBROUTINE closec
13125 END INTERFACE
13126#endif
13127
13128 lun=ithr
13129 !print *, " closing binary ", kfile, ithr
13130 IF(kfile <= nfilf) THEN ! Fortran file
13131 lun=kfile+10
13132 CLOSE(lun)
13133#ifdef READ_C_FILES
13134 ELSE ! C file
13135 CALL closec(lun)
13136#endif
13137 END IF
13138
13139END SUBROUTINE bincls
13140
13145SUBROUTINE binrwd(kfile)
13146 USE mpmod
13147
13148 IMPLICIT NONE
13149 INTEGER(mpi), INTENT(IN) :: kfile
13150
13151 INTEGER(mpi) :: lun
13152
13153#ifdef READ_C_FILES
13154 INTERFACE
13155 SUBROUTINE resetc(lun) BIND(c)
13156 USE iso_c_binding
13157 INTEGER(c_int), INTENT(IN), VALUE :: lun
13158 END SUBROUTINE resetc
13159 END INTERFACE
13160#endif
13161
13162 !print *, " rewinding binary ", kfile
13163 IF (kfile <= nfilf) THEN
13164 lun=kfile+10
13165 rewind lun
13166#ifdef READ_C_FILES
13167 ELSE
13168 lun=kfile-nfilf
13169 CALL resetc(lun)
13170#endif
13171 END IF
13172
13173END SUBROUTINE binrwd
13174
13176SUBROUTINE ckpgrp
13177 USE mpmod
13178 USE mpdalc
13179
13180 IMPLICIT NONE
13181 INTEGER(mpi) :: i
13182 INTEGER(mpi) :: ipgrp
13183 INTEGER(mpi) :: irank
13184 INTEGER(mpi) :: isize
13185 INTEGER(mpi) :: ivoff
13186 INTEGER(mpi) :: itgbi
13187 INTEGER(mpi) :: j
13188 INTEGER(mpi) :: msize
13189 INTEGER(mpi), PARAMETER :: mxsize = 1000
13190 INTEGER(mpl):: ij
13191 INTEGER(mpl):: length
13192
13193 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
13194 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
13195 REAL(mpd), DIMENSION(:), ALLOCATABLE :: resParGroup
13196 REAL(mpd), DIMENSION(:), ALLOCATABLE :: blockParGroup
13197 REAL(mpd) :: matij
13198 SAVE
13199
13200 ! maximal group size
13201 msize=0
13202 DO ipgrp=1,nvpgrp
13203 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13204 IF (isize <= mxsize) THEN
13205 msize=max(msize,isize)
13206 ELSE
13207 print *, ' CKPGRP: par. group', ipgrp, ' not checked -- too large: ', isize
13208 END IF
13209 END DO
13210 IF (msize == 0) RETURN
13211
13212 ! (matrix) block for parameter groups
13213 length=int(msize,mpl)*(int(msize,mpl)+1)/2
13214 CALL mpalloc(blockpargroup,length,'(matrix) block for parameter groups (D)')
13215 length=msize
13216 CALL mpalloc(respargroup,length,'residuals for parameter groups (D)') ! double aux 1
13217 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
13218 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
13219
13220 respargroup=0
13221 print *
13222 print *,' CKPGRP par. group first label size rank'
13223 DO ipgrp=1,nvpgrp
13224 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13225 IF (isize > mxsize) cycle
13226 ! copy matrix block
13227 ivoff=globalallindexgroups(ipgrp)-1
13228 ij=0
13229 DO i=1,isize
13230 DO j=1,i
13231 ij=ij+1
13232 blockpargroup(ij)=matij(ivoff+i,ivoff+j)
13233 END DO
13234 END DO
13235 ! inversion of matrix block
13236 CALL sqminv(blockpargroup,respargroup,isize,irank, auxvectord, auxvectori)
13237 !
13238 itgbi=globalparvartototal(globalallindexgroups(ipgrp))
13239 IF (isize == irank) THEN
13240 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank
13241 ELSE
13242 ndefpg=ndefpg+1
13243 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank, ' rank deficit !!!'
13244 END IF
13245 END DO
13246
13247 ! clean up
13248 CALL mpdealloc(auxvectord)
13249 CALL mpdealloc(auxvectori)
13250 CALL mpdealloc(respargroup)
13251 CALL mpdealloc(blockpargroup)
13252
13253END SUBROUTINE ckpgrp
13254
13256SUBROUTINE chkmat
13257 USE mpmod
13258
13259 IMPLICIT NONE
13260 INTEGER(mpl) :: i
13261 INTEGER(mpl) :: nan
13262 INTEGER(mpl) :: neg
13263
13264 print *, ' Checking global matrix(D) for NANs ', size(globalmatd,kind=mpl)
13265 nan=0
13266 DO i=1,size(globalmatd,kind=mpl)
13267 IF(.NOT.(globalmatd(i) <= 0.0_mpd).AND..NOT.(globalmatd(i) > 0.0_mpd)) THEN
13268 nan=nan+1
13269 print *, ' i, nan ', i, nan
13270 END IF
13271 END DO
13272
13273 IF (matsto > 1) RETURN
13274 print *
13275 print *, ' Checking diagonal elements ', nagb
13276 neg=0
13277 DO i=1,nagb
13278 IF(.NOT.(globalmatd(globalrowoffsets(i)+i) > 0.0_mpd)) THEN
13279 neg=neg+1
13280 print *, ' i, neg ', i, neg
13281 END IF
13282 END DO
13283 print *
13284 print *, ' CHKMAT summary ', nan, neg
13285 print *
13286
13287END SUBROUTINE chkmat
13288
13289
13290! ----- accurate summation ----(from mpnum) ---------------------------------
13291
13301
13302SUBROUTINE addsums(ithrd, chi2, ndf, dw)
13303 USE mpmod
13304
13305 IMPLICIT NONE
13306 REAL(mpd), INTENT(IN) :: chi2
13307 INTEGER(mpi), INTENT(IN) :: ithrd
13308 INTEGER(mpi), INTENT(IN) :: ndf
13309 REAL(mpd), INTENT(IN) :: dw
13310
13311 INTEGER(mpl) ::nadd
13312 REAL(mpd) ::add
13313 ! ...
13314 add=chi2*dw ! apply (file) weight
13315 nadd=int(add,mpl) ! convert to integer
13316 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+nadd ! sum integer
13317 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)+(add-real(nadd,mpd)) ! sum remainder
13318 IF(globalchi2sumd(ithrd) > 16.0_mpd) THEN ! + - 16
13319 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)-16.0_mpd
13320 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+16_mpl
13321 END IF
13322 globalndfsum(ithrd)=globalndfsum(ithrd)+int(ndf,mpl)
13323 globalndfsumw(ithrd)=globalndfsumw(ithrd)+real(ndf,mpd)*dw
13324 RETURN
13325END SUBROUTINE addsums
13326
13334
13335SUBROUTINE getsums(chi2, ndf, wndf)
13336 USE mpmod
13337
13338 IMPLICIT NONE
13339 REAL(mpd), INTENT(OUT) ::chi2
13340 INTEGER(mpl), INTENT(OUT) ::ndf
13341 REAL(mpd), INTENT(OUT) ::wndf
13342 ! ...
13343 chi2=sum(globalchi2sumd)+real(sum(globalchi2sumi),mpd)
13344 ndf=sum(globalndfsum)
13345 wndf=sum(globalndfsumw)
13346 globalchi2sumd=0.0_mpd
13347 globalchi2sumi=0_mpl
13348 globalndfsum=0_mpl
13349 globalndfsumw=0.0_mpd
13350 RETURN
13351END SUBROUTINE getsums
mpdalc::mpalloc
allocate array
Definition: mpdalc.f90:36
mpdalc::mpdealloc
deallocate array
Definition: mpdalc.f90:42
ptlopt
subroutine ptlopt(nf, m, slopes, steps)
Get details.
Definition: linesrch.f90:259
ptline
subroutine ptline(n, x, f, g, s, step, info)
Perform linesearch.
Definition: linesrch.f90:90
ptldef
subroutine ptldef(gtole, stmax, minfe, maxfe)
Initialize line search.
Definition: linesrch.f90:233
ptlprt
subroutine ptlprt(lunp)
Print line search data.
Definition: linesrch.f90:295
pcbits
subroutine pcbits(npgrp, nsparr, nsparc)
Analyze bit fields.
Definition: mpbits.f90:1018
ndbits
subroutine ndbits(npgrp, ndims, nsparr, ihst)
Analyze bit fields.
Definition: mpbits.f90:302
clbits
subroutine clbits(in, jreqpe, jhispe, jsngpe, jextnd, idimb, ispc)
Calculate bit (field) array size, encoding.
Definition: mpbits.f90:179
plbits
subroutine plbits(in, inar, inac, idimb)
Calculate bit field array size (PARDISO).
Definition: mpbits.f90:252
spbits
subroutine spbits(npgrp, nsparr, nsparc)
Create sparsity information.
Definition: mpbits.f90:1205
irbits
subroutine irbits(i, j)
Fill bit fields (counters, rectangular part).
Definition: mpbits.f90:146
clbmap
subroutine clbmap(in)
Clear (additional) bit map.
Definition: mpbits.f90:1342
inbmap
subroutine inbmap(im, jm)
Fill bit map.
Definition: mpbits.f90:1374
ckbits
subroutine ckbits(npgrp, ndims)
Check sparsity of matrix.
Definition: mpbits.f90:1112
ggbmap
subroutine ggbmap(ipgrp, npair, npgrp)
Get paired (parameter) groups from map.
Definition: mpbits.f90:1454
prbits
subroutine prbits(npgrp, nsparr)
Analyze bit fields.
Definition: mpbits.f90:919
gpbmap
subroutine gpbmap(ngroup, npgrp, npair)
Get pairs (statistic) from map.
Definition: mpbits.f90:1408
pblbits
subroutine pblbits(npgrp, ibsize, nsparr, nsparc)
Analyze bit fields.
Definition: mpbits.f90:752
pbsbits
subroutine pbsbits(npgrp, ibsize, nnzero, nblock, nbkrow)
Analyze bit fields.
Definition: mpbits.f90:575
inbits
subroutine inbits(im, jm, inc)
Fill bit fields (counters, triangular part).
Definition: mpbits.f90:70
hmplun
subroutine hmplun(lunw)
unit for output
Definition: mphistab.f90:329
gmpdef
subroutine gmpdef(ig, ityp, text)
book, reset XY storage
Definition: mphistab.f90:702
gmpxy
subroutine gmpxy(ig, x, y)
add (X,Y) pair
Definition: mphistab.f90:767
hmpdef
subroutine hmpdef(ih, xa, xb, text)
book, reset histogram
Definition: mphistab.f90:122
gmplun
subroutine gmplun(lunw)
unit for output
Definition: mphistab.f90:975
gmpxyd
subroutine gmpxyd(ig, x, y, dx, dy)
add (X,Y,DX,DY)
Definition: mphistab.f90:782
hmpwrt
subroutine hmpwrt(ih)
write histogram text file
Definition: mphistab.f90:341
gmpwrt
subroutine gmpwrt(ig)
write XY text file
Definition: mphistab.f90:987
hmpldf
subroutine hmpldf(ih, text)
book, reset log histogram
Definition: mphistab.f90:158
gmprnt
subroutine gmprnt(ig)
print XY data
Definition: mphistab.f90:869
hmpent
subroutine hmpent(ih, x)
entry flt.pt.
Definition: mphistab.f90:183
hmplnt
subroutine hmplnt(ih, ix)
entry integer
Definition: mphistab.f90:223
gmpms
subroutine gmpms(ig, x, y)
mean sigma(X) from Y
Definition: mphistab.f90:805
hmprnt
subroutine hmprnt(ih)
print, content vert
Definition: mphistab.f90:254
monend
subroutine monend()
End monitoring.
Definition: mpmon.f90:83
monini
subroutine monini(l, n1, n2)
Initialize monitoring.
Definition: mpmon.f90:43
sqmibb2
subroutine sqmibb2(v, b, n, nbdr, nbnd, inv, nrank, vbnd, vbdr, aux, vbk, vzru, scdiag, scflag)
Band bordered matrix.
Definition: mpnum.f90:3373
dbavat
subroutine dbavat(v, a, w, n, m, iopt)
A V AT product (similarity).
Definition: mpnum.f90:1390
sqminl
subroutine sqminl(v, b, n, nrank, diag, next, vk, mon)
Matrix inversion for LARGE matrices.
Definition: mpnum.f90:231
devsol
subroutine devsol(n, diag, u, b, x, work)
Solution by diagonalization.
Definition: mpnum.f90:650
dbsvxl
subroutine dbsvxl(v, a, b, n)
Product LARGE symmetric matrix, vector.
Definition: mpnum.f90:1309
devrot
subroutine devrot(n, diag, u, v, work, iwork)
Diagonalization.
Definition: mpnum.f90:370
sort22l
subroutine sort22l(a, b, n)
Quick sort 2 with index.
Definition: mpnum.f90:1982
dbavats
subroutine dbavats(v, a, is, w, n, m, iopt, sc)
A V AT product (similarity, sparse).
Definition: mpnum.f90:1471
chslv2
subroutine chslv2(g, x, n)
Solve A*x=b using Cholesky decomposition.
Definition: mpnum.f90:954
sort1k
subroutine sort1k(a, n)
Quick sort 1.
Definition: mpnum.f90:1715
sqminv
subroutine sqminv(v, b, n, nrank, diag, next)
Matrix inversion and solution.
Definition: mpnum.f90:98
presols
subroutine presols(p, n, b, nm, cu, a, l, s, x, y)
Constrained (sparse) preconditioner, solution.
Definition: mpnum.f90:2981
sqmibb
subroutine sqmibb(v, b, n, nbdr, nbnd, inv, nrank, vbnd, vbdr, aux, vbk, vzru, scdiag, scflag)
Bordered band matrix.
Definition: mpnum.f90:3117
devinv
subroutine devinv(n, diag, u, v)
Inversion by diagonalization.
Definition: mpnum.f90:697
equdecs
subroutine equdecs(n, m, b, nm, ls, c, india, l, nrkd, nrkd2)
Decomposition of (sparse) equilibrium systems.
Definition: mpnum.f90:2487
chdec2
subroutine chdec2(g, n, nrank, evmax, evmin, mon)
Cholesky decomposition (LARGE pos.
Definition: mpnum.f90:892
sort2k
subroutine sort2k(a, n)
Quick sort 2.
Definition: mpnum.f90:1800
devsig
subroutine devsig(n, diag, u, b, coef)
Calculate significances.
Definition: mpnum.f90:612
dbsvx
subroutine dbsvx(v, a, b, n)
Product symmetric matrix, vector.
Definition: mpnum.f90:1265
equslvs
subroutine equslvs(n, m, b, nm, c, india, l, x)
Solution of (sparse) equilibrium systems (after decomposition).
Definition: mpnum.f90:2614
precons
subroutine precons(p, n, b, nm, c, cu, a, l, s, nrkd)
Constrained (sparse) preconditioner, decomposition.
Definition: mpnum.f90:2882
sort2i
subroutine sort2i(a, n)
Quick sort 2 with index.
Definition: mpnum.f90:1893
qlpssq
subroutine qlpssq(aprod, B, m, t)
Partial similarity transformation by Q(t).
Definition: mpqldec.f90:696
qldecb
subroutine qldecb(a, bpar, bcon, rcon)
QL decomposition (for disjoint block matrix).
Definition: mpqldec.f90:216
qlmlq
subroutine qlmlq(x, m, t)
Multiply left by Q(t) (per block).
Definition: mpqldec.f90:395
qlsetb
subroutine qlsetb(ib)
Set block.
Definition: mpqldec.f90:997
qlbsub
subroutine qlbsub(d, y)
Backward substitution (per block).
Definition: mpqldec.f90:970
qlini
subroutine qlini(n, m, l, s, k)
Initialize QL decomposition.
Definition: mpqldec.f90:58
qlgete
subroutine qlgete(emin, emax)
Get eigenvalues.
Definition: mpqldec.f90:934
qlssq
subroutine qlssq(aprod, A, s, roff, t)
Similarity transformation by Q(t).
Definition: mpqldec.f90:564
mptest
subroutine mptest
Generate test files.
Definition: mptest1.f90:79
mptst2
subroutine mptst2(imodel)
Generate test files.
Definition: mptest2.f90:112
matint
integer(mpi) function matint(pat, text, npat, ntext)
Approximate string matching.
Definition: mptext.f90:309
ratext
subroutine ratext(text, nums, dnum, mnum)
Translate text.
Definition: mptext.f90:51
rltext
subroutine rltext(text, ia, ib, nab)
Analyse text range.
Definition: mptext.f90:256
minresmodule
MINRES solves symmetric systems Ax = b or min ||Ax - b||_2, where the matrix A may be indefinite and/...
Definition: minresModule.f90:39
minresmodule::minres
subroutine, public minres(n, Aprod, Msolve, b, shift, checkA, precon, x, itnlim, nout, rtol, istop, itn, Anorm, Acond, rnorm, Arnorm, ynorm)
Solution of linear equation system.
Definition: minresModule.f90:297
minresqlpmodule
MINRESQLP solves symmetric systems Ax = b or min ||Ax - b||_2, where the matrix A may be indefinite a...
Definition: minresqlpModule.f90:42
minresqlpmodule::minresqlp
subroutine, public minresqlp(n, Aprod, b, shift, Msolve, disable, nout, itnlim, rtol, maxxnorm, trancond, Acondlim, x, istop, itn, rnorm, Arnorm, xnorm, Anorm, Acond)
Solution of linear equation system or least squares problem.
Definition: minresqlpModule.f90:414
mpdalc
(De)Allocate vectors and arrays.
Definition: mpdalc.f90:24
mpdalc::maxwordsalloc
integer(mpl) maxwordsalloc
peak dynamic memory allocation (words)
Definition: mpdalc.f90:30
mpdalc::printflagalloc
integer(mpi) printflagalloc
print flag for dynamic allocations
Definition: mpdalc.f90:33
mpdef
Definition of constants.
Definition: mpdef.f90:24
mpdef::mpl
integer, parameter mpl
long integer
Definition: mpdef.f90:36
mpdef::mps
integer, parameter mps
single precision
Definition: mpdef.f90:37
mpdef::mpi
integer, parameter mpi
integer
Definition: mpdef.f90:35
mpmod
Parameters, variables, dynamic arrays.
Definition: mpmod.f90:28
mpmod::csr3columnlist
integer(mpl), dimension(:), allocatable csr3columnlist
list of columns for sparse matrix
Definition: mpmod.f90:281
mpmod::mszpcc
integer(mpl) mszpcc
(integrated block) matrix size for constraint matrix for preconditioner
Definition: mpmod.f90:144
mpmod::workspaceeigenvectors
real(mpd), dimension(:), allocatable workspaceeigenvectors
workspace eigen vectors
Definition: mpmod.f90:230
mpmod::globalparameter
real(mpd), dimension(:), allocatable globalparameter
global parameters (start values + sum(x_i))
Definition: mpmod.f90:196
mpmod::nrecal
integer(mpl) nrecal
number of records
Definition: mpmod.f90:166
mpmod::localglobalmap
integer(mpi), dimension(:), allocatable localglobalmap
matrix correlating local and global par, map (counts)
Definition: mpmod.f90:312
mpmod::listparameters
type(listitem), dimension(:), allocatable listparameters
list of parameters from steering file
Definition: mpmod.f90:329
mpmod::vecparblockconoffsets
integer(mpi), dimension(:), allocatable vecparblockconoffsets
global par block (constraint) offsets
Definition: mpmod.f90:296
mpmod::lapacktau
real(mpd), dimension(:), allocatable lapacktau
LAPACK TAU (QL decomp.)
Definition: mpmod.f90:236
mpmod::mszprd
integer(mpl) mszprd
(integrated block) matrix size for (constraint) product matrix
Definition: mpmod.f90:142
mpmod::lunmon
integer(mpi) lunmon
unit for monitoring output file
Definition: mpmod.f90:126
mpmod::vecconsresiduals
real(mpd), dimension(:), allocatable vecconsresiduals
residuals of constraints
Definition: mpmod.f90:242
mpmod::nrec1
integer(mpl) nrec1
record number with largest residual
Definition: mpmod.f90:53
mpmod::iskpec
integer(mpi) iskpec
flag for skipping empty constraints (no variable parameters)
Definition: mpmod.f90:106
mpmod::mnrsel
integer(mpi) mnrsel
number of MINRES error labels in LBMNRS (calc err, corr with SOLGLO)
Definition: mpmod.f90:89
mpmod::actfun
real(mps) actfun
actual function change
Definition: mpmod.f90:67
mpmod::globalindexusage
integer(mpi), dimension(:), allocatable globalindexusage
indices of global par in record
Definition: mpmod.f90:289
mpmod::regpre
real(mps) regpre
default presigma
Definition: mpmod.f90:72
mpmod::mnrsit
integer(mpi) mnrsit
total number of MINRES internal iterations
Definition: mpmod.f90:93
mpmod::ipdbsz
integer(mpi), dimension(10) ipdbsz
PARDISO, list of block sizes to be tried (by PBSBITS)
Definition: mpmod.f90:183
mpmod::metsol
integer(mpi) metsol
solution method (1: inversion, 2: diagonalization, 3: decomposition, 4: MINRES, 5: MINRES-QLP,...
Definition: mpmod.f90:34
mpmod::nagbn
integer(mpi) nagbn
max number of global paramters per record
Definition: mpmod.f90:145
mpmod::textl
character(len=74) textl
name of current MP 'module' (step)
Definition: mpmod.f90:157
mpmod::nloopn
integer(mpi) nloopn
number of data reading, fitting loops
Definition: mpmod.f90:43
mpmod::sumrecords
integer(mpl) sumrecords
sum of records
Definition: mpmod.f90:188
mpmod::mreqpe
integer(mpi) mreqpe
min number of pair entries
Definition: mpmod.f90:80
mpmod::memdbg
integer(mpi) memdbg
debug flag for memory management
Definition: mpmod.f90:96
mpmod::lbmnrs
integer(mpi), dimension(100) lbmnrs
MINRES error labels.
Definition: mpmod.f90:177
mpmod::ncgrp
integer(mpi) ncgrp
number of (disjoint) constraint groups
Definition: mpmod.f90:139
mpmod::mrtcnd
real(mpd) mrtcnd
transition (QR -> QLP) (matrix) condition for MINRES-QLP
Definition: mpmod.f90:62
mpmod::vbk
real(mpd), dimension(:), allocatable vbk
local fit 'matrix for border solution'
Definition: mpmod.f90:305
mpmod::prange
real(mps) prange
range (-PRANGE..PRANGE) for histograms of pulls, norm.
Definition: mpmod.f90:97
mpmod::matsto
integer(mpi) matsto
(global) matrix storage mode (0: unpacked, 1: full = packed, 2: sparse(custom), 3: sparse(CSR3,...
Definition: mpmod.f90:35
mpmod::matconssort
integer(mpi), dimension(:,:), allocatable matconssort
keys and index for sorting
Definition: mpmod.f90:247
mpmod::lapackwork
real(mpd), dimension(:), allocatable lapackwork
LAPACK work array.
Definition: mpmod.f90:237
mpmod::monpg1
integer(mpi) monpg1
progress monitoring, repetition rate start value
Definition: mpmod.f90:116
mpmod::readbufferinfo
integer(mpi), dimension(:,:), allocatable readbufferinfo
buffer management (per thread)
Definition: mpmod.f90:283
mpmod::nhistp
integer(mpi) nhistp
flag for histogram printout
Definition: mpmod.f90:65
mpmod::csr3rowoffsets
integer(mpl), dimension(:), allocatable csr3rowoffsets
row offsets for column list
Definition: mpmod.f90:280
mpmod::globalparcopy
real(mpd), dimension(:), allocatable globalparcopy
copy of global parameters
Definition: mpmod.f90:197
mpmod::lapackql
real(mpd), dimension(:), allocatable lapackql
LAPACK QL (QL decomp.)
Definition: mpmod.f90:235
mpmod::dscerr
real(mpd), dimension(2) dscerr
scaling factors for errors of 'global' and 'local' measurement
Definition: mpmod.f90:112
mpmod::chhuge
real(mps) chhuge
cut in terms of 3-sigma for unreasonable data, all iterations
Definition: mpmod.f90:50
mpmod::sparsematrixcolumns
integer(mpi), dimension(:), allocatable sparsematrixcolumns
(compressed) list of columns for sparse matrix
Definition: mpmod.f90:277
mpmod::sparsematrixoffsets
integer(mpl), dimension(:,:), allocatable sparsematrixoffsets
row offsets for column list, sparse matrix elements
Definition: mpmod.f90:278
mpmod::iteren
integer(mpi) iteren
entries cut is iterated for parameters with less entries (if > mreqenf)
Definition: mpmod.f90:105
mpmod::matconsranges
integer(mpi), dimension(:,:), allocatable matconsranges
parameter ranges for constraints
Definition: mpmod.f90:246
mpmod::lunkno
integer(mpi) lunkno
flag for unkown keywords
Definition: mpmod.f90:46
mpmod::scflag
integer(mpi), dimension(:), allocatable scflag
local fit workspace (I)
Definition: mpmod.f90:308
mpmod::measbinsize
real(mpd), parameter measbinsize
bins size for monitoring
Definition: mpmod.f90:176
mpmod::mdebug
integer(mpi) mdebug
debug flag (number of records to print)
Definition: mpmod.f90:38
mpmod::npblck
integer(mpi) npblck
number of (disjoint) parameter blocks (>1: block diagonal storage)
Definition: mpmod.f90:138
mpmod::matconsproduct
real(mpd), dimension(:), allocatable matconsproduct
product matrix of constraints
Definition: mpmod.f90:241
mpmod::yfd
integer(mpi), dimension(:), allocatable yfd
binary file: modification date
Definition: mpmod.f90:360
mpmod::nxlow
integer(mpi) nxlow
(max of) global parameters with too few accepted entries for icalcm=1
Definition: mpmod.f90:171
mpmod::ndgb
integer(mpl) ndgb
number of global derivatives read
Definition: mpmod.f90:152
mpmod::value1
real(mps) value1
largest residual
Definition: mpmod.f90:55
mpmod::ipddbg
integer(mpi) ipddbg
flag for debugging Intel oneMKL PARDISO
Definition: mpmod.f90:121
mpmod::localcorrections
real(mpd), dimension(:), allocatable localcorrections
local fit corrections (to residuals)
Definition: mpmod.f90:310
mpmod::nrec3
integer(mpl) nrec3
(1.) record number with error
Definition: mpmod.f90:79
mpmod::chirem
real(mps) chirem
cut in terms of 3-sigma cut, other iterations, approaching 1.
Definition: mpmod.f90:49
mpmod::localglobalmatrix
real(mpd), dimension(:), allocatable localglobalmatrix
matrix correlating local and global par, content
Definition: mpmod.f90:311
mpmod::mhispe
integer(mpi) mhispe
upper bound for pair entry histogrammimg
Definition: mpmod.f90:81
mpmod::nfgb
integer(mpi) nfgb
number of fit parameters
Definition: mpmod.f90:132
mpmod::kfd
integer(mpi), dimension(:,:), allocatable kfd
(1,.)= number of records in file, (2,..)= file order
Definition: mpmod.f90:351
mpmod::globalchi2sumd
real(mpd), dimension(:), allocatable globalchi2sumd
fractional part of Chi2 sum
Definition: mpmod.f90:219
mpmod::icheck
integer(mpi) icheck
flag for checking input only (no solution determined)
Definition: mpmod.f90:103
mpmod::jfd
integer(mpi), dimension(:), allocatable jfd
file: number of accepted records
Definition: mpmod.f90:353
mpmod::nrecer
integer(mpl) nrecer
record with error (rank deficit or Not-a-Number) for printout
Definition: mpmod.f90:78
mpmod::matmon
integer(mpi) matmon
record interval for monitoring of (sparse) matrix construction
Definition: mpmod.f90:86
mpmod::nbndx
integer(mpi) nbndx
max band width for local fit
Definition: mpmod.f90:77
mpmod::listconstraints
type(listitem), dimension(:), allocatable listconstraints
list of constraints from steering file
Definition: mpmod.f90:333
mpmod::globalmatd
real(mpd), dimension(:), allocatable globalmatd
global matrix 'A' (double, full or sparse)
Definition: mpmod.f90:205
mpmod::readbufferdatad
real(mpr8), dimension(:), allocatable readbufferdatad
double data
Definition: mpmod.f90:287
mpmod::listmeasurements
type(listitem), dimension(:), allocatable listmeasurements
list of (external) measurements from steering file
Definition: mpmod.f90:336
mpmod::lsinfo
integer(mpi) lsinfo
line search: returned information
Definition: mpmod.f90:162
mpmod::nregul
integer(mpi) nregul
regularization flag
Definition: mpmod.f90:70
mpmod::nfilw
integer(mpi) nfilw
number of weighted binary files
Definition: mpmod.f90:369
mpmod::ndefpg
integer(mpi) ndefpg
number of parameter groups with rank deficit (from inversion)
Definition: mpmod.f90:168
mpmod::paircounter
integer(mpi), dimension(:), allocatable paircounter
number of paired parameters (in equations)
Definition: mpmod.f90:292
mpmod::nummeasurements
integer(mpi) nummeasurements
number of (external) measurements from steering file
Definition: mpmod.f90:334
mpmod::nrejec
integer(mpi), dimension(0:3) nrejec
rejected events
Definition: mpmod.f90:154
mpmod::nrec2
integer(mpl) nrec2
record number with largest chi^2/Ndf
Definition: mpmod.f90:54
mpmod::ndimbuf
integer(mpi) ndimbuf
default read buffer size (I/F words, half record length)
Definition: mpmod.f90:370
mpmod::fvalue
real(mpd) fvalue
function value (chi2 sum) solution
Definition: mpmod.f90:178
mpmod::globalcorrections
real(mpd), dimension(:), allocatable globalcorrections
correction x_i (from A*x_i=b_i in iteration i)
Definition: mpmod.f90:198
mpmod::cfd
real(mps), dimension(:), allocatable cfd
file: chi2 sum
Definition: mpmod.f90:356
mpmod::regula
real(mps) regula
regularization parameter, add regula * norm(global par.) to objective function
Definition: mpmod.f90:71
mpmod::nspc
integer(mpi) nspc
number of precision for sparse global matrix (1=D, 2=D+F)
Definition: mpmod.f90:173
mpmod::nfilc
integer(mpi) nfilc
number of C binary files
Definition: mpmod.f90:368
mpmod::nagb
integer(mpi) nagb
number of all parameters (var.
Definition: mpmod.f90:131
mpmod::nmiss1
integer(mpi) nmiss1
rank deficit for constraints
Definition: mpmod.f90:169
mpmod::globalparhashtable
integer(mpi), dimension(:), allocatable globalparhashtable
global parameters hash table
Definition: mpmod.f90:259
mpmod::nalow
integer(mpi) nalow
(sum of) global parameters with too few accepted entries
Definition: mpmod.f90:170
mpmod::iscerr
integer(mpi) iscerr
flag for scaling of errors
Definition: mpmod.f90:111
mpmod::sumndf
real(mpd) sumndf
weighted sum(ndf)
Definition: mpmod.f90:180
mpmod::nbndr
integer(mpi), dimension(2) nbndr
number of records with bordered band matrix for local fit (upper/left, lower/right)
Definition: mpmod.f90:75
mpmod::lapackipiv
integer(mpl), dimension(:), allocatable lapackipiv
LAPACK IPIV (pivot)
Definition: mpmod.f90:238
mpmod::iterat
integer(mpi) iterat
iterations in solution
Definition: mpmod.f90:69
mpmod::flines
real(mpd) flines
function value line search
Definition: mpmod.f90:179
mpmod::meashists
integer(mpi), dimension(:), allocatable meashists
measurement histograms (100 bins per thread)
Definition: mpmod.f90:254
mpmod::globalindexranges
integer(mpi), dimension(:), allocatable globalindexranges
global par ranges
Definition: mpmod.f90:294
mpmod::mthrd
integer(mpi) mthrd
number of (OpenMP) threads
Definition: mpmod.f90:84
mpmod::mbandw
integer(mpi) mbandw
band width of preconditioner matrix
Definition: mpmod.f90:44
mpmod::lplwrk
integer(mpl) lplwrk
length of LAPACK WORK array
Definition: mpmod.f90:234
mpmod::dwcut
real(mps) dwcut
down-weight fraction cut
Definition: mpmod.f90:57
mpmod::globalcounter
integer(mpl), dimension(:), allocatable globalcounter
global counter (entries in 'x')
Definition: mpmod.f90:209
mpmod::globalmatf
real(mps), dimension(:), allocatable globalmatf
global matrix 'A' (float part for compressed sparse)
Definition: mpmod.f90:206
mpmod::matconsgroups
integer(mpi), dimension(:,:), allocatable matconsgroups
start of constraint groups, parameter range
Definition: mpmod.f90:248
mpmod::times
real(mps), dimension(0:8) times
cpu time counters
Definition: mpmod.f90:155
mpmod::minrecordsinblock
integer(mpi) minrecordsinblock
min.
Definition: mpmod.f90:190
mpmod::localglobalstructure
integer(mpi), dimension(:), allocatable localglobalstructure
matrix correlating local and global par, (sparsity) structure
Definition: mpmod.f90:313
mpmod::globalndfsumw
real(mpd), dimension(:), allocatable globalndfsumw
weighted NDF sum
Definition: mpmod.f90:222
mpmod::naeqn
integer(mpi) naeqn
max number of equations (measurements) per record
Definition: mpmod.f90:147
mpmod::nfilb
integer(mpi) nfilb
number of binary files
Definition: mpmod.f90:366
mpmod::vzru
real(mpd), dimension(:), allocatable vzru
local fit 'border solution'
Definition: mpmod.f90:306
mpmod::globalparpreweight
real(mpd), dimension(:), allocatable globalparpreweight
weight from pre-sigma
Definition: mpmod.f90:201
mpmod::ictest
integer(mpi) ictest
test mode '-t'
Definition: mpmod.f90:33
mpmod::vbdr
real(mpd), dimension(:), allocatable vbdr
local fit border part of 'A'
Definition: mpmod.f90:303
mpmod::mdebg2
integer(mpi) mdebg2
number of measurements for record debug printout
Definition: mpmod.f90:39
mpmod::globaltotindexgroups
integer(mpi), dimension(:,:), allocatable globaltotindexgroups
Definition: mpmod.f90:273
mpmod::vecconsgroupcounts
integer(mpi), dimension(:), allocatable vecconsgroupcounts
counter for constraint groups
Definition: mpmod.f90:249
mpmod::deltim
real(mps) deltim
cpu time difference
Definition: mpmod.f90:164
mpmod::igcorr
integer(mpi) igcorr
flag for output of global correlations for inversion, =0: none
Definition: mpmod.f90:95
mpmod::globalparheader
integer(mpi), dimension(-8:0) globalparheader
global parameters (mapping) header
Definition: mpmod.f90:262
mpmod::lencomments
integer(mpi) lencomments
length of list of (global parameter) comments from steering file
Definition: mpmod.f90:337
mpmod::offprecond
integer(mpl), dimension(:), allocatable offprecond
preconditioner (block matrix) offsets
Definition: mpmod.f90:217
mpmod::vecconssolution
real(mpd), dimension(:), allocatable vecconssolution
solution for constraint elimination
Definition: mpmod.f90:243
mpmod::nfiles
integer(mpi) nfiles
number of files
Definition: mpmod.f90:365
mpmod::ipcntr
integer(mpi) ipcntr
flag for output of global parameter counts (entries), =0: none, =1: local fits, >1: binary files
Definition: mpmod.f90:100
mpmod::negb
integer(mpl) negb
number of equations read with global parameters
Definition: mpmod.f90:151
mpmod::keepopen
integer(mpi) keepopen
flag for keeping binary files open
Definition: mpmod.f90:113
mpmod::workspacediagonalization
real(mpd), dimension(:), allocatable workspacediagonalization
workspace diag.
Definition: mpmod.f90:228
mpmod::wfd
real(mps), dimension(:), allocatable wfd
binary file: weight
Definition: mpmod.f90:358
mpmod::matprecond
real(mpd), dimension(:), allocatable matprecond
preconditioner matrix (band and other parts)
Definition: mpmod.f90:214
mpmod::ntgb
integer(mpi) ntgb
total number of global parameters
Definition: mpmod.f90:129
mpmod::angras
real(mps) angras
angle between gradient and search direction
Definition: mpmod.f90:68
mpmod::listcomments
type(listitemc), dimension(:), allocatable listcomments
list of comments from steering file
Definition: mpmod.f90:338
mpmod::mthrdr
integer(mpi) mthrdr
number of threads for reading binary files
Definition: mpmod.f90:92
mpmod::numreadbuffer
integer(mpi) numreadbuffer
number of buffers (records) in (read) block
Definition: mpmod.f90:186
mpmod::imonmd
integer(mpi) imonmd
monitoring mode: 0:residuals (normalized to average error), 1:pulls
Definition: mpmod.f90:110
mpmod::filnam
character(len=1024) filnam
name of steering file
Definition: mpmod.f90:361
mpmod::lunlog
integer(mpi) lunlog
unit for logfile
Definition: mpmod.f90:127
mpmod::ncblck
integer(mpi) ncblck
number of (non overlapping) constraint blocks
Definition: mpmod.f90:140
mpmod::fcache
real(mps), dimension(3) fcache
read cache, average fill level; write cache; dynamic size
Definition: mpmod.f90:91
mpmod::wolfc2
real(mps) wolfc2
C_2 of strong Wolfe condition.
Definition: mpmod.f90:60
mpmod::workspacerow
real(mpd), dimension(:), allocatable workspacerow
(pivot) row of global matrix (for global corr.)
Definition: mpmod.f90:226
mpmod::maxrecordsinblock
integer(mpi) maxrecordsinblock
max.
Definition: mpmod.f90:191
mpmod::mrestl
real(mpd) mrestl
tolerance criterion for MINRES-QLP
Definition: mpmod.f90:61
mpmod::globalparpresigma
real(mpd), dimension(:), allocatable globalparpresigma
pre-sigma for global parameters
Definition: mpmod.f90:200
mpmod::icelim
integer(mpi) icelim
flag for using elimination (instead of multipliers) for constraints
Definition: mpmod.f90:102
mpmod::mitera
integer(mpi) mitera
number of iterations
Definition: mpmod.f90:42
mpmod::lenpardiso
integer(mpi) lenpardiso
length of list of Intel oneMKL PARDISO parameters (indices 1..64)
Definition: mpmod.f90:341
mpmod::nbdrx
integer(mpi) nbdrx
max border size for local fit
Definition: mpmod.f90:76
mpmod::globalparlabelindex
integer(mpi), dimension(:,:), allocatable globalparlabelindex
global parameters label, total -> var.
Definition: mpmod.f90:257
mpmod::scdiag
real(mpd), dimension(:), allocatable scdiag
local fit workspace (D)
Definition: mpmod.f90:307
mpmod::readbufferdatai
integer(mpi), dimension(:), allocatable readbufferdatai
integer data
Definition: mpmod.f90:285
mpmod::mextnd
integer(mpi) mextnd
flag for extended storage (both 'halves' of sym.
Definition: mpmod.f90:83
mpmod::sfd
integer(mpi), dimension(:,:), allocatable sfd
offset (1,..), length (2,..) of binary file name in tfd
Definition: mpmod.f90:359
mpmod::lenconstraints
integer(mpi) lenconstraints
length of list of constraints from steering file
Definition: mpmod.f90:332
mpmod::blockprecond
integer(mpi), dimension(:), allocatable blockprecond
preconditioner (constraint) blocks
Definition: mpmod.f90:216
mpmod::lenparameters
integer(mpi) lenparameters
list items from steering file
Definition: mpmod.f90:328
mpmod::lprecm
integer(mpi) lprecm
additional flag for preconditioner (band) matrix (>0: preserve rank by skyline matrix)
Definition: mpmod.f90:45
mpmod::ndefec
integer(mpi) ndefec
rank deficit for global matrix (from inversion)
Definition: mpmod.f90:167
mpmod::nrecp2
integer(mpl) nrecp2
record number with printout
Definition: mpmod.f90:52
mpmod::nrec
integer(mpl) nrec
number of records read
Definition: mpmod.f90:148
mpmod::matparblockoffsets
integer(mpi), dimension(:,:), allocatable matparblockoffsets
global par block offsets (parameter, constraint blocks)
Definition: mpmod.f90:295
mpmod::nrecpr
integer(mpl) nrecpr
record number with printout
Definition: mpmod.f90:51
mpmod::ifd
integer(mpl), dimension(:), allocatable ifd
file: integrated record numbers (=offset)
Definition: mpmod.f90:352
mpmod::nofeas
integer(mpi) nofeas
flag for skipping making parameters feasible
Definition: mpmod.f90:64
mpmod::matbsz
integer(mpi) matbsz
(global) matrix (fixed) block size, only used for BSR3 storage mode (Intel oneMKL PARDISO)
Definition: mpmod.f90:36
mpmod::nfnam
integer(mpi) nfnam
length of sterring file name
Definition: mpmod.f90:362
mpmod::rstart
real rstart
cpu start time for solution iterations
Definition: mpmod.f90:163
mpmod::writebufferindices
integer(mpi), dimension(:), allocatable writebufferindices
write buffer for indices
Definition: mpmod.f90:317
mpmod::iforce
integer(mpi) iforce
switch to SUBITO for (global) rank defects if zero
Definition: mpmod.f90:94
mpmod::workspacelinesearch
real(mpd), dimension(:), allocatable workspacelinesearch
workspace line search
Definition: mpmod.f90:227
mpmod::globalparvartototal
integer(mpi), dimension(:), allocatable globalparvartototal
global parameters variable -> total index
Definition: mpmod.f90:260
mpmod::clmat
real(mpd), dimension(:), allocatable clmat
local fit matrix 'A' (in A*x=b)
Definition: mpmod.f90:299
mpmod::lfd
integer(mpi), dimension(:), allocatable lfd
length of file name
Definition: mpmod.f90:349
mpmod::ntpgrp
integer(mpi) ntpgrp
number of parameter groups
Definition: mpmod.f90:135
mpmod::tfd
character, dimension(:), allocatable tfd
file names (concatenation)
Definition: mpmod.f90:363
mpmod::ncgbe
integer(mpi) ncgbe
number of empty constraints (no variable parameters)
Definition: mpmod.f90:134
mpmod::mprint
integer(mpi) mprint
print flag (0: minimal, 1: normal, >1: more)
Definition: mpmod.f90:37
mpmod::vecconsstart
integer(mpi), dimension(:), allocatable vecconsstart
start of constraint in listConstraints (unsorted input)
Definition: mpmod.f90:245
mpmod::nummeas
integer(mpi) nummeas
number of measurement groups for monitoring
Definition: mpmod.f90:175
mpmod::lvllog
integer(mpi) lvllog
log level
Definition: mpmod.f90:128
mpmod::nprecond
integer(mpi), dimension(3) nprecond
number of constraints (blocks), matrix size for preconditioner
Definition: mpmod.f90:143
mpmod::nalcn
integer(mpi) nalcn
max number of local paramters per record
Definition: mpmod.f90:146
mpmod::globalparcomments
integer(mpi), dimension(:), allocatable globalparcomments
global parameters comments
Definition: mpmod.f90:203
mpmod::mreqenf
integer(mpi) mreqenf
required number of entries (for variable global parameter from binary Files)
Definition: mpmod.f90:40
mpmod::value2
real(mps) value2
largest chi^2/Ndf
Definition: mpmod.f90:56
mpmod::icalcm
integer(mpi) icalcm
calculation mode (for XLOOPN) , >0: calculate matrix
Definition: mpmod.f90:74
mpmod::mcount
integer(mpi) mcount
flag for grouping and counting global parameters on equlation (0) or record (1) level
Definition: mpmod.f90:115
mpmod::ofd
real(mps), dimension(:), allocatable ofd
file: option
Definition: mpmod.f90:357
mpmod::ireeof
integer(mpi) ireeof
flag for treating (binary file) read errors as end-of-file
Definition: mpmod.f90:114
mpmod::ifile
integer(mpi) ifile
current file (index)
Definition: mpmod.f90:364
mpmod::delfun
real(mps) delfun
expected function change
Definition: mpmod.f90:66
mpmod::iitera
integer(mpi) iitera
MINRES iterations.
Definition: mpmod.f90:160
mpmod::skippedrecords
integer(mpl) skippedrecords
number of skipped records (buffer too small)
Definition: mpmod.f90:189
mpmod::lenmeasurements
integer(mpi) lenmeasurements
length of list of (external) measurements from steering file
Definition: mpmod.f90:335
mpmod::wolfc1
real(mps) wolfc1
C_1 of strong Wolfe condition.
Definition: mpmod.f90:59
mpmod::aux
real(mpd), dimension(:), allocatable aux
local fit 'solutions for border rows'
Definition: mpmod.f90:304
mpmod::napgrp
integer(mpi) napgrp
number of all parameter groups (variable + Lagrange mult.)
Definition: mpmod.f90:137
mpmod::nrecd
integer(mpl) nrecd
number of records read containing doubles
Definition: mpmod.f90:149
mpmod::localequations
integer(mpi), dimension(:,:), allocatable localequations
indices (ISJAJB) for local equations (measurements)
Definition: mpmod.f90:309
mpmod::globalallpartogroup
integer(mpi), dimension(:), allocatable globalallpartogroup
all parameters variable -> group index
Definition: mpmod.f90:261
mpmod::backindexusage
integer(mpi), dimension(:), allocatable backindexusage
list of global par in record
Definition: mpmod.f90:290
mpmod::ibandh
integer(mpi), dimension(:), allocatable ibandh
local fit 'band width histogram' (band size autodetection)
Definition: mpmod.f90:300
mpmod::isubit
integer(mpi) isubit
subito flag '-s'
Definition: mpmod.f90:58
mpmod::indprecond
integer(mpi), dimension(:), allocatable indprecond
preconditioner pointer array
Definition: mpmod.f90:215
mpmod::dflim
real(mps) dflim
convergence limit
Definition: mpmod.f90:153
mpmod::ncache
integer(mpi) ncache
buffer size for caching (default 100MB per thread)
Definition: mpmod.f90:90
mpmod::mxrec
integer(mpi) mxrec
max number of records
Definition: mpmod.f90:85
mpmod::mpdbsz
integer(mpi) mpdbsz
PARDISO, number of block sizes to be tried (by PBSBITS)
Definition: mpmod.f90:182
mpmod::lfitnp
integer(mpi) lfitnp
local fit: number of iteration to calculate pulls
Definition: mpmod.f90:87
mpmod::globalparlabelcounter
integer(mpl), dimension(:), allocatable globalparlabelcounter
global parameters label counters
Definition: mpmod.f90:258
mpmod::lcalcm
integer(mpi) lcalcm
last calclation mode
Definition: mpmod.f90:172
mpmod::globalvector
real(mpd), dimension(:), allocatable globalvector
global vector 'x' (in A*x=b)
Definition: mpmod.f90:207
mpmod::writebufferupdates
real(mpd), dimension(:), allocatable writebufferupdates
write buffer for update matrices
Definition: mpmod.f90:318
mpmod::irslvrc
integer(mpi) irslvrc
flag for resolving redundancy constraints (two equivalent parameter groups)
Definition: mpmod.f90:107
mpmod::workspaced
real(mpd), dimension(:), allocatable workspaced
(general) workspace (D)
Definition: mpmod.f90:224
mpmod::neqn
integer(mpl) neqn
number of equations (measurements) read
Definition: mpmod.f90:150
mpmod::measbins
integer(mpi) measbins
number of bins per measurement for monitoring
Definition: mpmod.f90:109
mpmod::mszcon
integer(mpl) mszcon
(integrated block) matrix size for constraint matrix
Definition: mpmod.f90:141
mpmod::nfd
integer(mpi), dimension(:), allocatable nfd
index (line) in (steering) file
Definition: mpmod.f90:350
mpmod::ilperr
integer(mpi) ilperr
flag to calculate parameter errors with LAPACK
Definition: mpmod.f90:119
mpmod::numblocks
integer(mpi) numblocks
number of (read) blocks
Definition: mpmod.f90:187
mpmod::ncgb
integer(mpi) ncgb
number of constraints
Definition: mpmod.f90:133
mpmod::matconsblocks
integer(mpi), dimension(:,:), allocatable matconsblocks
start of constraint blocks, parameter range
Definition: mpmod.f90:251
mpmod::workspaceeigenvalues
real(mpd), dimension(:), allocatable workspaceeigenvalues
workspace eigen values
Definition: mpmod.f90:229
mpmod::lhuber
integer(mpi) lhuber
Huber down-weighting flag.
Definition: mpmod.f90:47
mpmod::nvgb
integer(mpi) nvgb
number of variable global parameters
Definition: mpmod.f90:130
mpmod::nfilf
integer(mpi) nfilf
number of Fortran binary files
Definition: mpmod.f90:367
mpmod::measindex
integer(mpi), dimension(:), allocatable measindex
mapping of 1.
Definition: mpmod.f90:253
mpmod::istopa
integer(mpi) istopa
MINRES istop (convergence)
Definition: mpmod.f90:161
mpmod::mfd
integer(mpi), dimension(:), allocatable mfd
file mode: cbinary =1, text =2, fbinary=3
Definition: mpmod.f90:348
mpmod::blvec
real(mpd), dimension(:), allocatable blvec
local fit vector 'b' (in A*x=b), replaced by 'x'
Definition: mpmod.f90:298
mpmod::newite
logical newite
flag for new iteration
Definition: mpmod.f90:158
mpmod::nrderr
integer(mpi) nrderr
number of binary files with read errors
Definition: mpmod.f90:181
mpmod::measres
real(mpd), dimension(:), allocatable measres
average measurement error
Definition: mpmod.f90:255
mpmod::vecxav
real(mpd), dimension(:), allocatable vecxav
vector x for AVPROD (A*x=b)
Definition: mpmod.f90:211
mpmod::globalparstart
real(mpd), dimension(:), allocatable globalparstart
start value for global parameters
Definition: mpmod.f90:199
mpmod::writebufferheader
integer(mpi), dimension(-6:6) writebufferheader
write buffer header (-6..-1: updates, 1..6: indices)
Definition: mpmod.f90:319
mpmod::monpg2
integer(mpi) monpg2
progress monitoring, repetition rate max increase
Definition: mpmod.f90:117
mpmod::globalrowoffsets
integer(mpl), dimension(:), allocatable globalrowoffsets
row offsets for full or unpacked matrix
Definition: mpmod.f90:208
mpmod::lenpresigmas
integer(mpi) lenpresigmas
length of list of pre-sigmas from steering file
Definition: mpmod.f90:330
mpmod::npresg
integer(mpi) npresg
number of pre-sigmas
Definition: mpmod.f90:165
mpmod::appearancecounter
integer(mpi), dimension(:), allocatable appearancecounter
appearance statistics for global par (first/last file,record)
Definition: mpmod.f90:291
mpmod::nvpgrp
integer(mpi) nvpgrp
number of variable parameter groups
Definition: mpmod.f90:136
mpmod::xfd
integer(mpi), dimension(:), allocatable xfd
file: max.
Definition: mpmod.f90:355
mpmod::mreqena
integer(mpi) mreqena
required number of entries (for variable global parameter from Accepted local fits)
Definition: mpmod.f90:41
mpmod::writebufferdata
real(mps), dimension(:,:), allocatable writebufferdata
write buffer data (largest residual, Chi2/ndf, per thread)
Definition: mpmod.f90:316
mpmod::workspacediag
real(mpd), dimension(:), allocatable workspacediag
diagonal of global matrix (for global corr.)
Definition: mpmod.f90:225
mpmod::ndfsum
integer(mpl) ndfsum
sum(ndf)
Definition: mpmod.f90:159
mpmod::lenglobalvec
integer(mpi) lenglobalvec
length of global vector 'b' (A*x=b)
Definition: mpmod.f90:192
mpmod::stepl
real(mps) stepl
step length (line search)
Definition: mpmod.f90:156
mpmod::msngpe
integer(mpi) msngpe
upper bound for pair entry single precision storage
Definition: mpmod.f90:82
mpmod::vecbav
real(mpd), dimension(:), allocatable vecbav
vector b for AVPROD (A*x=b)
Definition: mpmod.f90:212
mpmod::globalchi2sumi
integer(mpl), dimension(:), allocatable globalchi2sumi
integer part of Chi2 sum
Definition: mpmod.f90:220
mpmod::ipdmem
integer(mpl) ipdmem
memory (kB) used by Intel oneMKL PARDISO
Definition: mpmod.f90:343
mpmod::readbufferpointer
integer(mpi), dimension(:), allocatable readbufferpointer
pointer to used buffers
Definition: mpmod.f90:284
mpmod::workspacei
integer(mpi), dimension(:), allocatable workspacei
(general) workspace (I)
Definition: mpmod.f90:231
mpmod::globalparcons
integer(mpi), dimension(:), allocatable globalparcons
global parameters (number of) constraints
Definition: mpmod.f90:202
mpmod::writebufferinfo
integer(mpi), dimension(:,:), allocatable writebufferinfo
write buffer management (per thread)
Definition: mpmod.f90:315
mpmod::globalndfsum
integer(mpl), dimension(:), allocatable globalndfsum
NDF sum.
Definition: mpmod.f90:221
mpmod::matrit
integer(mpi) matrit
matrix calculation up to iteration MATRIT
Definition: mpmod.f90:73
mpmod::vbnd
real(mpd), dimension(:), allocatable vbnd
local fit band part of 'A'
Definition: mpmod.f90:302
mpmod::readbufferdataf
real(mpr4), dimension(:), allocatable readbufferdataf
float data
Definition: mpmod.f90:286
mpmod::listpardiso
type(listitemi), dimension(:), allocatable listpardiso
list of Intel oneMKL PARDISO parameters
Definition: mpmod.f90:342
mpmod::lfitbb
integer(mpi) lfitbb
local fit: check for bordered band matrix (if >0)
Definition: mpmod.f90:88
mpmod::lsearch
integer(mpi) lsearch
iterations (solutions) with line search: >2: all, =2: all with (next) Chi2 cut scaling factor =1....
Definition: mpmod.f90:98
mpmod::dfd
integer(mpi), dimension(:), allocatable dfd
file: ndf sum
Definition: mpmod.f90:354
mpmod::ichkpg
integer(mpi) ichkpg
flag for checking (rank of) parameter groups
Definition: mpmod.f90:104
mpmod::listpresigmas
type(listitem), dimension(:), allocatable listpresigmas
list of pre-sgmas from steering file
Definition: mpmod.f90:331
mpmod::globalallindexgroups
integer(mpi), dimension(:), allocatable globalallindexgroups
Definition: mpmod.f90:274
mpmod::mrmode
integer(mpi) mrmode
MINRES-QLP mode (0: QR+QLP, 1: only QR, 2: only QLP factorization)
Definition: mpmod.f90:63
mpmod::chicut
real(mps) chicut
cut in terms of 3-sigma cut, first iteration
Definition: mpmod.f90:48
mpmod::imonit
integer(mpi) imonit
flag for monitoring residuals per local fit cycle (=0: none, <0: all, bit 0: first,...
Definition: mpmod.f90:108
mptest1
Parameters and data.
Definition: mptest1.f90:35
mptest1::dvd
real(mps), dimension(nplan) dvd
rel.
Definition: mptest1.f90:53
mptest1::del
real(mps), dimension(nplan) del
shift (position deviation) (alignment parameter)
Definition: mptest1.f90:52
mptest1::nplan
integer(mpi), parameter nplan
Definition: mptest1.f90:41
mptest2
Parameters and data.
Definition: mptest2.f90:57
mptest2::nmx
integer(mpi), parameter nmx
number of modules in x direction
Definition: mptest2.f90:65
mptest2::sdevx
real(mps), dimension(ntot) sdevx
shift in x (alignment parameter)
Definition: mptest2.f90:82
mptest2::sdevy
real(mps), dimension(ntot) sdevy
shift in y (alignment parameter)
Definition: mptest2.f90:83
mptest2::nmy
integer(mpi), parameter nmy
number of modules in y direction
Definition: mptest2.f90:67
mptest2::nlyr
integer(mpi), parameter nlyr
number of detector layers
Definition: mptest2.f90:63
mptest2::ntot
integer(mpi), parameter ntot
total number of modules
Definition: mptest2.f90:68
mptext
Keyword position.
Definition: mptext.f90:29
mptext::keyb
integer(mpi) keyb
end (position) of first keyword
Definition: mptext.f90:35
mptext::keya
integer(mpi) keya
start (position) of first keyword
Definition: mptext.f90:34
mptext::keyc
integer(mpi) keyc
end (position) of last keyword
Definition: mptext.f90:36
ploopb
subroutine ploopb(lunp)
Print iteration line.
Definition: pede.f90:3801
mchdec
subroutine mchdec
Solution by Cholesky decomposition.
Definition: pede.f90:8916
bincls
subroutine bincls(kfile, ithr)
Close binary file.
Definition: pede.f90:13111
prpcon
subroutine prpcon
Prepare constraints.
Definition: pede.f90:1913
mminrs
subroutine mminrs
Solution with MINRES.
Definition: pede.f90:9930
mcsolv
subroutine mcsolv(n, x, y)
Solution for zero band width preconditioner.
Definition: pede.f90:10134
mupdat
subroutine mupdat(i, j, add)
Update element of global matrix.
Definition: pede.f90:4023
peend
subroutine peend(icode, cmessage)
Print exit code.
Definition: pede.f90:12994
loopn
subroutine loopn
Loop with fits and sums.
Definition: pede.f90:3360
loop1
subroutine loop1
First data loop (get global labels).
Definition: pede.f90:6816
feasma
subroutine feasma
Matrix for feasible solution.
Definition: pede.f90:2213
xloopn
subroutine xloopn
Standard solution algorithm.
Definition: pede.f90:10188
ploopa
subroutine ploopa(lunp)
Print title for iteration.
Definition: pede.f90:3780
isjajb
subroutine isjajb(nst, is, ja, jb, jsp)
Decode Millepede record.
Definition: pede.f90:3309
additem
subroutine additem(length, list, label, value)
add item to list
Definition: pede.f90:12734
mgupdt
subroutine mgupdt(i, j1, j2, il, jl, n, sub)
Update global matrix for parameter group.
Definition: pede.f90:4108
lpavat
subroutine lpavat(t)
Similarity transformation by Q(t).
Definition: pede.f90:9448
binrwd
subroutine binrwd(kfile)
Rewind binary file.
Definition: pede.f90:13146
zdiags
subroutine zdiags
Covariance matrix for diagonalization (,correction of eigenvectors).
Definition: pede.f90:9893
solglo
subroutine solglo(ivgbi)
Error for single global parameter from MINRES.
Definition: pede.f90:1374
upone
subroutine upone
Update, redefine hash indices.
Definition: pede.f90:6682
pargrp
subroutine pargrp(inds, inde)
Parameter group info update for block of parameters.
Definition: pede.f90:3191
prtglo
subroutine prtglo
Print final log file.
Definition: pede.f90:5301
monres
subroutine monres
Monitor input residuals.
Definition: pede.f90:8505
intext
subroutine intext(text, nline)
Interprete text.
Definition: pede.f90:11872
ijadd
integer(mpl) function ijadd(itema, itemb)
Index for sparse storage (custom).
Definition: pede.f90:6315
mdiags
subroutine mdiags
Solution by diagonalization.
Definition: pede.f90:9744
mptwo
program mptwo
Millepede II main program Pede.
Definition: pede.f90:885
prtstat
subroutine prtstat
Print input statistic.
Definition: pede.f90:5486
matij
real(mpd) function matij(itema, itemb)
Get matrix element at (i,j).
Definition: pede.f90:6422
grpcon
subroutine grpcon
Group constraints.
Definition: pede.f90:1615
loopbf
subroutine loopbf(nrej, numfil, naccf, chi2f, ndff)
Loop over records in read buffer (block), fits and sums.
Definition: pede.f90:4276
peread
subroutine peread(more)
Read (block of) records from binary files.
Definition: pede.f90:2549
filetx
subroutine filetx
Interprete text files.
Definition: pede.f90:11549
iprime
integer(mpi) function iprime(n)
largest prime number < N.
Definition: pede.f90:6784
ploopc
subroutine ploopc(lunp)
Print sub-iteration line.
Definition: pede.f90:3858
ijcsr3
integer(mpl) function ijcsr3(itema, itemb)
Index for sparse storage (CSR3).
Definition: pede.f90:6364
useone
subroutine useone
Make usable (sort items and redefine hash indices).
Definition: pede.f90:6752
mvopen
subroutine mvopen(lun, fname)
Open file.
Definition: pede.f90:12906
chkrej
subroutine chkrej
Check rejection details.
Definition: pede.f90:11009
avprd0
subroutine avprd0(n, l, x, b)
Product symmetric (sub block) matrix times vector.
Definition: pede.f90:5886
addsums
subroutine addsums(ithrd, chi2, ndf, dw)
Accurate summation.
Definition: pede.f90:13303
solgloqlp
subroutine solgloqlp(ivgbi)
Error for single global parameter from MINRES-QLP.
Definition: pede.f90:1458
lpqldec
subroutine lpqldec(a, emin, emax)
QL decomposition.
Definition: pede.f90:9332
addcst
subroutine addcst
Add constraint information to matrix and vector.
Definition: pede.f90:1541
petime
subroutine petime
Print times.
Definition: pede.f90:12943
mstart
subroutine mstart(text)
Start of 'module' printout.
Definition: pede.f90:12853
mend
subroutine mend
End of 'module' printout.
Definition: pede.f90:12889
anasps
subroutine anasps
Analyse sparsity structure.
Definition: pede.f90:6054
minver
subroutine minver
Solution by matrix inversion.
Definition: pede.f90:8803
peprep
subroutine peprep(mode)
Prepare records.
Definition: pede.f90:2900
ijprec
integer(mpi) function ijprec(itema, itemb)
Precision for storage of parameter groups.
Definition: pede.f90:6286
explfc
subroutine explfc(lunit)
Print explanation of iteration table.
Definition: pede.f90:3932
getsums
subroutine getsums(chi2, ndf, wndf)
Get accurate sums.
Definition: pede.f90:13336
chkmat
subroutine chkmat
Check global matrix.
Definition: pede.f90:13257
binopn
subroutine binopn(kfile, ithr, ierr)
Open binary file.
Definition: pede.f90:13015
pepgrp
subroutine pepgrp
Parameter group info update.
Definition: pede.f90:3067
sechms
subroutine sechms(deltat, nhour, minut, secnd)
Time conversion.
Definition: pede.f90:6567
inone
integer(mpi) function inone(item)
Translate labels to indices (for global parameters).
Definition: pede.f90:6612
avprds
subroutine avprds(n, l, x, is, ie, b)
Product symmetric (sub block) matrix times sparse vector.
Definition: pede.f90:5672
avprod
subroutine avprod(n, x, b)
Product symmetric matrix times vector.
Definition: pede.f90:6148
ijpgrp
subroutine ijpgrp(itema, itemb, ij, lr, iprc)
Index (region length and precision) for sparse storage of parameter groups.
Definition: pede.f90:6188
loop1i
subroutine loop1i
Iteration of first data loop.
Definition: pede.f90:7179
mhalf2
subroutine mhalf2
Fill 2nd half of matrix for extended storage.
Definition: pede.f90:6480
ckpgrp
subroutine ckpgrp
Check (rank of) parameter groups.
Definition: pede.f90:13177
additemi
subroutine additemi(length, list, label, ivalue)
add item to list
Definition: pede.f90:12818
mminrsqlp
subroutine mminrsqlp
Solution with MINRES-QLP.
Definition: pede.f90:10028
filetc
subroutine filetc
Interprete command line option, steering file.
Definition: pede.f90:11073
feasib
subroutine feasib(concut, iact)
Make parameters feasible.
Definition: pede.f90:2388
mspardiso
subroutine mspardiso
Solution with Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO.
Definition: pede.f90:9539
mdutrf
subroutine mdutrf
Solution by factorization.
Definition: pede.f90:9163
mdptrf
subroutine mdptrf
Solution by factorization.
Definition: pede.f90:9028
mvsolv
subroutine mvsolv(n, x, y)
Solution for finite band width preconditioner.
Definition: pede.f90:10155
vmprep
subroutine vmprep(msize)
Prepare storage for vectors and matrices.
Definition: pede.f90:8606
ploopd
subroutine ploopd(lunp)
Print solution line.
Definition: pede.f90:3906
pechk
subroutine pechk(ibuf, nerr)
Check Millepede record.
Definition: pede.f90:2995
loop2
subroutine loop2
Second data loop (number of derivatives, global label pairs).
Definition: pede.f90:7291
nufile
integer(mpi) function nufile(fname)
Inquire on file.
Definition: pede.f90:11815
additemc
subroutine additemc(length, list, label, text)
add character item to list
Definition: pede.f90:12776
resetc
void resetc(int nFileIn)
Rewind file.
Definition: readc.c:185
initc
void initc(int nFiles)
Initialises the 'global' variables used for file handling.
Definition: readc.c:91
closec
void closec(int nFileIn)
Close file.
Definition: readc.c:168
readc
void readc(double *bufferDouble, float *bufferFloat, int *bufferInt, int *lengthBuffers, int nFileIn, int *errorFlag)
Read record from file.
Definition: readc.c:219
openc
void openc(const char *fileName, int lfn, int nFileIn, int *errorFlag)
Open file.
Definition: readc.c:110
mpdef::listitem
list items from steering file
Definition: mpdef.f90:40
mpdef::listitemc
character list items from steering file
Definition: mpdef.f90:47
mpdef::listitemi
integer list items from steering file
Definition: mpdef.f90:52
Generated on Thu May 2 2024 11:10:01 for Millepede-II by doxygen 1.9.3