Millepede-II V04-17-05
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
282
569
570
830
868
911
912#ifdef SCOREP_USER_ENABLE
913#include "scorep/SCOREP_User.inc"
914#endif
915
917PROGRAM mptwo
918 USE mpmod
919 USE mpdalc
920 USE mptest1, ONLY: nplan,del,dvd
921 USE mptest2, ONLY: nlyr,nmx,nmy,sdevx,sdevy,ntot
922
923 IMPLICIT NONE
924 REAL(mps) :: andf
925 REAL(mps) :: c2ndf
926 REAL(mps) :: deltat
927 REAL(mps) :: diff
928 REAL(mps) :: err
929 REAL(mps) :: gbu
930 REAL(mps) :: gmati
931 REAL(mps) :: rej
932 REAL :: rloop1
933 REAL :: rloop2
934 REAL :: rstext
935 REAL(mps) :: secnd
936 REAL :: rst
937 REAL :: rstp
938 REAL, DIMENSION(2) :: ta
939 INTEGER(mpi) :: i
940 INTEGER(mpi) :: ii
941 INTEGER(mpi) :: iopnmp
942 INTEGER(mpi) :: ix
943 INTEGER(mpi) :: ixv
944 INTEGER(mpi) :: iy
945 INTEGER(mpi) :: k
946 INTEGER(mpi) :: kfl
947 INTEGER(mpi) :: lun
948 INTEGER :: minut
949 INTEGER :: nhour
950 INTEGER(mpi) :: nmxy
951 INTEGER(mpi) :: nrc
952 INTEGER(mpi) :: nsecnd
953 INTEGER(mpi) :: ntsec
954
955 CHARACTER (LEN=24) :: chdate
956 CHARACTER (LEN=24) :: chost
957#ifdef LAPACK64
958 CHARACTER (LEN=6) :: c6
959 INTEGER major, minor, patch
960#endif
961
962 INTEGER(mpl) :: rows
963 INTEGER(mpl) :: cols
964
965 REAL(mpd) :: sums(9)
966 !$ INTEGER(mpi) :: OMP_GET_NUM_PROCS,OMP_GET_MAX_THREADS
967 !$ INTEGER(mpi) :: MXTHRD
968 !$ INTEGER(mpi) :: NPROC
969
970 REAL etime
971
972 SAVE
973 ! ...
974 rstp=etime(ta)
975 CALL fdate(chdate)
976
977 ! millepede monitoring file
978 lunmon=0
979 ! millepede.log file
980 lunlog=8
981 lvllog=1
982 CALL mvopen(lunlog,'millepede.log')
983 CALL getenv('HOSTNAME',chost)
984 IF (chost(1:1) == ' ') CALL getenv('HOST',chost)
985 WRITE(*,*) '($Id: dd0c569a1aafb6f6eb2f26b9b9537a685639ca25 $)'
986 iopnmp=0
987 !$ iopnmp=1
988 !$ WRITE(*,*) 'using OpenMP (TM)'
989#ifdef LAPACK64
990 CALL ilaver( major,minor, patch )
991 WRITE(*,110) lapack64, major,minor, patch
992110 FORMAT(' using LAPACK64 with ',(a),', version ',i0,'.',i0,'.',i0)
993#ifdef PARDISO
994 WRITE(*,*) 'using Intel oneMKL PARDISO'
995#endif
996#endif
997#ifdef __GFORTRAN__
998 WRITE(*,111) __gnuc__ , __gnuc_minor__ , __gnuc_patchlevel__
999111 FORMAT(' compiled with gcc ',i0,'.',i0,'.',i0)
1000#endif
1001#ifdef __PGIC__
1002 WRITE(*,111) __pgic__ , __pgic_minor__ , __pgic_patchlevel__
1003111 FORMAT(' compiled with pgi ',i0,'.',i0,'.',i0)
1004#endif
1005#ifdef SCOREP_USER_ENABLE
1006 WRITE(*,*) 'instrumenting Score-P user regions'
1007#endif
1008 WRITE(*,*) ' '
1009 WRITE(*,*) ' < Millepede II-P starting ... ',chdate
1010 WRITE(*,*) ' ',chost
1011 WRITE(*,*) ' '
1012
1013 WRITE(8,*) '($Id: dd0c569a1aafb6f6eb2f26b9b9537a685639ca25 $)'
1014 WRITE(8,*) ' '
1015 WRITE(8,*) 'Log-file Millepede II-P ', chdate
1016 WRITE(8,*) ' ', chost
1017
1018 CALL peend(-1,'Still running or crashed')
1019 ! read command line and text files
1020
1021 CALL filetc ! command line and steering file analysis
1022 CALL filetx ! read text files
1023 ! dummy call for dynamic memory allocation
1024 CALL gmpdef(0,nfilb,'dummy call')
1025
1026 IF (icheck > 0) THEN
1027 WRITE(*,*) '!!! Checking input only, no calculation of a solution !!!'
1028 WRITE(8,*) '!!! Checking input only, no calculation of a solution !!!'
1029 END IF
1030 lvllog=mprint ! export print level
1031 IF (memdbg > 0) printflagalloc=1 ! debug memory management
1032 !$ WRITE(*,*)
1033 !$ NPROC=1
1034 !$ MXTHRD=1
1035 !$ NPROC=OMP_GET_NUM_PROCS() ! number of processors available
1036 !$ CALL OMP_SET_NUM_THREADS(MTHRD) ! set max number of threads to MTHRD
1037 !$ MXTHRD=OMP_GET_MAX_THREADS() ! get max number of threads back
1038 !$ WRITE(*,*) 'Number of processors available: ', NPROC
1039 !$ WRITE(*,*) 'Maximum number of OpenMP threads: ', MXTHRD
1040 !$ WRITE(*,*) 'Number of threads for processing: ', MTHRD
1041 !$ IF (MXREC.GT.0) MTHRDR=1 ! to get allways the same MXREC records
1042 !$ IF (ICHECK.GT.1) MTHRDR=1 ! to get allways the same order of records
1043 !$ WRITE(*,*) 'Number of threads for reading: ', MTHRDR
1044 !$POMP INST INIT ! start profiling with ompP
1045#ifdef LAPACK64
1046 IF(iopnmp > 0) THEN
1047 CALL getenv('OMP_NUM_THREADS',c6)
1048 ELSE
1049 CALL getenv(lapack64//'_NUM_THREADS',c6)
1050 END IF
1051 IF (c6(1:1) == ' ') THEN
1052 IF(iopnmp > 0) THEN
1053 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty OMP_NUM_THREADS)'
1054 ELSE
1055 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty ',lapack64//'_NUM_THREADS)'
1056 END IF
1057 ELSE
1058 WRITE(*,*) 'Number of threads for LAPACK: ', c6
1059 END IF
1060#endif
1061 cols=mthrd
1062 CALL mpalloc(globalchi2sumd,cols,'fractional part of Chi2 sum')
1063 globalchi2sumd=0.0_mpd
1064 CALL mpalloc(globalchi2sumi,cols,'integer part of Chi2 sum')
1065 globalchi2sumi=0_mpl
1066 CALL mpalloc(globalndfsum,cols,'NDF sum')
1067 globalndfsum=0_mpl
1068 CALL mpalloc(globalndfsumw,cols,'weighted NDF sum')
1069 globalndfsumw=0.0_mpd
1070
1071 IF (ncache < 0) THEN
1072 ncache=25000000*mthrd ! default cache size (100 MB per thread)
1073 ENDIF
1074 rows=6; cols=mthrdr
1075 CALL mpalloc(readbufferinfo,rows,cols,'read buffer header')
1076 ! histogram file
1077 lun=7
1078 CALL mvopen(lun,'millepede.his')
1079 CALL hmplun(lun) ! unit for histograms
1080 CALL gmplun(lun) ! unit for xy data
1081
1082 ! debugging
1083 IF(nrecpr /= 0.OR.nrecp2 /= 0) THEN
1084 CALL mvopen(1,'mpdebug.txt')
1085 END IF
1086
1087 rstext=etime(ta)
1088 times(0)=rstext-rstp ! time for text processing
1089
1090 ! preparation of data sub-arrays
1091
1092 CALL loop1
1093 rloop1=etime(ta)
1094 times(1)=rloop1-rstext ! time for LOOP1
1095
1096 CALL loop2
1097 IF(chicut /= 0.0) THEN
1098 WRITE(8,*) 'Chi square cut equiv 3 st.dev applied ...'
1099 WRITE(8,*) ' in first iteration with factor',chicut
1100 WRITE(8,*) ' in second iteration with factor',chirem
1101 WRITE(8,*) ' (reduced by sqrt in next iterations)'
1102 END IF
1103
1104 IF(lhuber /= 0) THEN
1105 WRITE(8,*) 'Down-weighting of outliers in', lhuber,' iterations'
1106 WRITE(8,*) 'Cut on downweight fraction',dwcut
1107 END IF
1108
1109 rloop2=etime(ta)
1110 times(2)=rloop2-rloop1 ! time for LOOP2
1111
1112 IF(icheck > 0) THEN
1113 CALL prtstat
1114 IF (ncgbe < 0) THEN
1115 CALL peend(5,'Ended without solution (empty constraints)')
1116 ELSE
1117 CALL peend(0,'Ended normally')
1118 END IF
1119 GOTO 99 ! only checking input
1120 END IF
1121
1122 ! use different solution methods
1123
1124 CALL mstart('Iteration') ! Solution module starting
1125
1126 CALL xloopn ! all methods
1127
1128 ! ------------------------------------------------------------------
1129
1130 IF(nloopn > 2.AND.nhistp /= 0) THEN ! last iteration
1131 CALL hmprnt(3) ! scaled residual of single measurement (with global deriv.)
1132 CALL hmprnt(12) ! scaled residual of single measurement (no global deriv.)
1133 CALL hmprnt(4) ! chi^2/Ndf
1134 END IF
1135 IF(nloopn > 2) THEN
1136 CALL hmpwrt(3)
1137 CALL hmpwrt(12)
1138 CALL hmpwrt(4)
1139 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
1140 IF (nloopn <= lfitnp) THEN
1141 CALL hmpwrt(13)
1142 CALL hmpwrt(14)
1143 CALL gmpwrt(5)
1144 END IF
1145 END IF
1146 IF(nhistp /= 0) THEN
1147 CALL gmprnt(1)
1148 CALL gmprnt(2)
1149 END IF
1150 CALL gmpwrt(1) ! output of xy data
1151 CALL gmpwrt(2) ! output of xy data
1152 ! 'track quality' per binary file
1153 IF (nfilb > 1) THEN
1154 CALL gmpdef(6,1,'log10(#records) vs file number')
1155 CALL gmpdef(7,1,'final rejection fraction vs file number')
1156 CALL gmpdef(8,1, &
1157 'final <Chi^2/Ndf> from accepted local fits vs file number')
1158 CALL gmpdef(9,1, '<Ndf> from accepted local fits vs file number')
1159
1160 DO i=1,nfilb
1161 kfl=kfd(2,i)
1162 nrc=-kfd(1,i)
1163 IF (nrc > 0) THEN
1164 rej=real(nrc-jfd(kfl),mps)/real(nrc,mps)
1165 CALL gmpxy(6,real(kfl,mps),log10(real(nrc,mps))) ! log10(#records) vs file
1166 CALL gmpxy(7,real(kfl,mps),rej) ! rejection fraction vs file
1167 END IF
1168 IF (jfd(kfl) > 0) THEN
1169 c2ndf=cfd(kfl)/real(jfd(kfl),mps)
1170 CALL gmpxy(8,real(kfl,mps),c2ndf) ! <Chi2/NDF> vs file
1171 andf=real(dfd(kfl),mps)/real(jfd(kfl),mps)
1172 CALL gmpxy(9,real(kfl,mps),andf) ! <NDF> vs file
1173 END IF
1174 END DO
1175 IF(nhistp /= 0) THEN
1176 CALL gmprnt(6)
1177 CALL gmprnt(7)
1178 CALL gmprnt(8)
1179 CALL gmprnt(9)
1180 END IF
1181 CALL gmpwrt(6) ! output of xy data
1182 CALL gmpwrt(7) ! output of xy data
1183 CALL gmpwrt(8) ! output of xy data
1184 CALL gmpwrt(9) ! output of xy data
1185 END IF
1186
1187 IF(ictest == 1) THEN
1188 WRITE(*,*) ' '
1189 WRITE(*,*) 'Misalignment test wire chamber'
1190 WRITE(*,*) ' '
1191
1192 CALL hmpdef( 9,-0.0015,+0.0015,'True - fitted displacement')
1193 CALL hmpdef(10,-0.0015,+0.0015,'True - fitted Vdrift')
1194 DO i=1,4
1195 sums(i)=0.0_mpd
1196 END DO
1197 DO i=1,nplan
1198 diff=real(-del(i)-globalparameter(i),mps)
1199 sums(1)=sums(1)+diff
1200 sums(2)=sums(2)+diff*diff
1201 diff=real(-dvd(i)-globalparameter(100+i),mps)
1202 sums(3)=sums(3)+diff
1203 sums(4)=sums(4)+diff*diff
1204 END DO
1205 sums(1)=0.01_mpd*sums(1)
1206 sums(2)=sqrt(0.01_mpd*sums(2))
1207 sums(3)=0.01_mpd*sums(3)
1208 sums(4)=sqrt(0.01_mpd*sums(4))
1209 WRITE(*,143) 'Parameters 1 - 100: mean =',sums(1), 'rms =',sums(2)
1210 WRITE(*,143) 'Parameters 101 - 200: mean =',sums(3), 'rms =',sums(4)
1211143 FORMAT(6x,a28,f9.6,3x,a5,f9.6)
1212 WRITE(*,*) ' '
1213 WRITE(*,*) ' '
1214 WRITE(*,*) ' I label simulated fitted diff'
1215 WRITE(*,*) ' -------------------------------------------- '
1216 DO i=1,100
1217 WRITE(*,102) i,globalparlabelindex(1,i),-del(i),globalparameter(i),-del(i)-globalparameter(i)
1218 diff=real(-del(i)-globalparameter(i),mps)
1219 CALL hmpent( 9,diff)
1220 END DO
1221 DO i=101,200
1222 WRITE(*,102) i,globalparlabelindex(1,i),-dvd(i-100),globalparameter(i),-dvd(i-100)-globalparameter(i)
1223 diff=real(-dvd(i-100)-globalparameter(i),mps)
1224 CALL hmpent(10,diff)
1225 END DO
1226 IF(nhistp /= 0) THEN
1227 CALL hmprnt( 9)
1228 CALL hmprnt(10)
1229 END IF
1230 CALL hmpwrt( 9)
1231 CALL hmpwrt(10)
1232 END IF
1233 IF(ictest > 1) THEN
1234 WRITE(*,*) ' '
1235 WRITE(*,*) 'Misalignment test Si tracker'
1236 WRITE(*,*) ' '
1237
1238 CALL hmpdef( 9,-0.0025,+0.0025,'True - fitted displacement X')
1239 CALL hmpdef(10,-0.025,+0.025,'True - fitted displacement Y')
1240 DO i=1,9
1241 sums(i)=0.0_mpd
1242 END DO
1243 nmxy=nmx*nmy
1244 ix=0
1245 iy=ntot
1246 DO i=1,nlyr
1247 DO k=1,nmxy
1248 ix=ix+1
1249 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1250 sums(1)=sums(1)+1.0_mpd
1251 sums(2)=sums(2)+diff
1252 sums(3)=sums(3)+diff*diff
1253 ixv=globalparlabelindex(2,ix)
1254 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1255 ii=(ixv*ixv+ixv)/2
1256 gmati=real(globalmatd(ii),mps)
1257 err=sqrt(abs(gmati))
1258 diff=diff/err
1259 sums(7)=sums(7)+1.0_mpd
1260 sums(8)=sums(8)+diff
1261 sums(9)=sums(9)+diff*diff
1262 END IF
1263 END DO
1264 IF (mod(i,3) == 1) THEN
1265 DO k=1,nmxy
1266 iy=iy+1
1267 diff=-real(sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1268 sums(4)=sums(4)+1.0_mpd
1269 sums(5)=sums(5)+diff
1270 sums(6)=sums(6)+diff*diff
1271 ixv=globalparlabelindex(2,iy)
1272 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1273 ii=(ixv*ixv+ixv)/2
1274 gmati=real(globalmatd(ii),mps)
1275 err=sqrt(abs(gmati))
1276 diff=diff/err
1277 sums(7)=sums(7)+1.0_mpd
1278 sums(8)=sums(8)+diff
1279 sums(9)=sums(9)+diff*diff
1280 END IF
1281 END DO
1282 END IF
1283 END DO
1284 sums(2)=sums(2)/sums(1)
1285 sums(3)=sqrt(sums(3)/sums(1))
1286 sums(5)=sums(5)/sums(4)
1287 sums(6)=sqrt(sums(6)/sums(4))
1288 WRITE(*,143) 'Parameters 1 - 500: mean =',sums(2), 'rms =',sums(3)
1289 WRITE(*,143) 'Parameters 501 - 700: mean =',sums(5), 'rms =',sums(6)
1290 IF (sums(7) > 0.5_mpd) THEN
1291 sums(8)=sums(8)/sums(7)
1292 sums(9)=sqrt(sums(9)/sums(7))
1293 WRITE(*,143) 'Parameter pulls, all: mean =',sums(8), 'rms =',sums(9)
1294 END IF
1295 WRITE(*,*) ' '
1296 WRITE(*,*) ' '
1297 WRITE(*,*) ' I label simulated fitted diff'
1298 WRITE(*,*) ' -------------------------------------------- '
1299 ix=0
1300 iy=ntot
1301 DO i=1,nlyr
1302 DO k=1,nmxy
1303 ix=ix+1
1304 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1305 CALL hmpent( 9,diff)
1306 WRITE(*,102) ix,globalparlabelindex(1,ix),-sdevx((i-1)*nmxy+k),globalparameter(ix),-diff
1307 END DO
1308 END DO
1309 DO i=1,nlyr
1310 IF (mod(i,3) == 1) THEN
1311 DO k=1,nmxy
1312 iy=iy+1
1313 diff=real(-sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1314 CALL hmpent(10,diff)
1315 WRITE(*,102) iy,globalparlabelindex(1,iy),-sdevy((i-1)*nmxy+k),globalparameter(iy),-diff
1316 END DO
1317 END IF
1318 END DO
1319 IF(nhistp /= 0) THEN
1320 CALL hmprnt( 9)
1321 CALL hmprnt(10)
1322 END IF
1323 CALL hmpwrt( 9)
1324 CALL hmpwrt(10)
1325 END IF
1326
1327 IF(nrec1+nrec2 > 0) THEN
1328 WRITE(8,*) ' '
1329 IF(nrec1 > 0) THEN
1330 WRITE(8,*) 'Record',nrec1,' has largest residual:',value1
1331 END IF
1332 IF(nrec2 > 0) THEN
1333 WRITE(8,*) 'Record',nrec2,' has largest Chi^2/Ndf:',value2
1334 END IF
1335 END IF
1336 IF(nrec3 < huge(nrec3)) THEN
1337 WRITE(8,*) 'Record',nrec3, ' is first with error (rank deficit/NaN)'
1338 END IF
133999 WRITE(8,*) ' '
1340 IF (iteren > mreqenf) THEN
1341 WRITE(8,*) 'In total 3 +',nloopn,' loops through the data files'
1342 ELSE
1343 WRITE(8,*) 'In total 2 +',nloopn,' loops through the data files'
1344 ENDIF
1345 IF (mnrsit > 0) THEN
1346 WRITE(8,*) ' '
1347 WRITE(8,*) 'In total ',mnrsit,' internal MINRES iterations'
1348 END IF
1349
1350 WRITE(8,103) times(0),times(1),times(2),times(4),times(7), &
1351 times(5),times(8),times(3),times(6)
1352
1353 rst=etime(ta)
1354 deltat=rst-rstp
1355 ntsec=nint(deltat,mpi)
1356 CALL sechms(deltat,nhour,minut,secnd)
1357 nsecnd=nint(secnd,mpi) ! round
1358 WRITE(8,*) 'Total time =',ntsec,' seconds =',nhour,' h',minut, &
1359 ' m',nsecnd,' seconds'
1360 CALL fdate(chdate)
1361 WRITE(8,*) 'end ', chdate
1362 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1363 WRITE(8,*) ' '
1364 WRITE(8,105) gbu
1365
1366 ! Rejects ----------------------------------------------------------
1367
1368 IF(sum(nrejec) /= 0) THEN
1369 WRITE(8,*) ' '
1370 WRITE(8,*) 'Data records rejected in last iteration: '
1371 CALL prtrej(8)
1372 WRITE(8,*) ' '
1373 END IF
1374 IF (icheck <= 0) CALL explfc(8)
1375
1376 WRITE(*,*) ' '
1377 WRITE(*,*) ' < Millepede II-P ending ... ', chdate ! with exit code',ITEXIT,' >'
1378 WRITE(*,*) ' '
1379 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1380 WRITE(*,105) gbu
1381#ifdef LAPACK64
1382#ifdef PARDISO
1383 IF(ipdmem > 0) WRITE(*,106) real(ipdmem,mps)*1.e-6
1384106 FORMAT(' PARDISO dyn. memory allocation: ',f11.6,' GB')
1385#endif
1386#endif
1387 WRITE(*,*) ' '
1388 ! close files
1389 CLOSE(unit=7) ! histogram file
1390 CLOSE(unit=8) ! log file
1391
1392 ! post processing?
1393 IF (lenpostproc > 0) THEN
1394 WRITE(*,*) 'Postprocessing:'
1395 IF (lenpostproc >= 80) THEN
1396 WRITE(*,*) cpostproc(1:38) // ' .. ' // cpostproc(lenpostproc-37:lenpostproc)
1397 ELSE
1398 WRITE(*,*) cpostproc(1:lenpostproc)
1399 ENDIF
1400 WRITE(*,*) ' '
1401 CALL system(cpostproc(1:lenpostproc))
1402 END IF
1403
1404102 FORMAT(2x,i4,i10,2x,3f10.5)
1405103 FORMAT(' Times [in sec] for text processing',f12.3/ &
1406 ' LOOP1',f12.3/ &
1407 ' LOOP2',f12.3/ &
1408 ' func. value ',f12.3,' *',f4.0/ &
1409 ' func. value, global matrix, solution',f12.3,' *',f4.0/ &
1410 ' new solution',f12.3,' *',f4.0/)
1411105 FORMAT(' Peak dynamic memory allocation: ',f11.6,' GB')
1412END PROGRAM mptwo ! Mille
1413
1420
1421SUBROUTINE solglo(ivgbi)
1422 USE mpmod
1423 USE minresmodule, ONLY: minres
1424
1425 IMPLICIT NONE
1426 REAL(mps) :: par
1427 REAL(mps) :: dpa
1428 REAL(mps) :: err
1429 REAL(mps) :: gcor2
1430 INTEGER(mpi) :: iph
1431 INTEGER(mpi) :: istop
1432 INTEGER(mpi) :: itgbi
1433 INTEGER(mpi) :: itgbl
1434 INTEGER(mpi) :: itn
1435 INTEGER(mpi) :: itnlim
1436 INTEGER(mpi) :: nout
1437
1438 INTEGER(mpi), INTENT(IN) :: ivgbi
1439
1440 REAL(mpd) :: shift
1441 REAL(mpd) :: rtol
1442 REAL(mpd) :: anorm
1443 REAL(mpd) :: acond
1444 REAL(mpd) :: arnorm
1445 REAL(mpd) :: rnorm
1446 REAL(mpd) :: ynorm
1447 REAL(mpd) :: gmati
1448 REAL(mpd) :: diag
1449 REAL(mpd) :: matij
1450 LOGICAL :: checka
1451 EXTERNAL avprod, mcsolv, mvsolv
1452 SAVE
1453 DATA iph/0/
1454 ! ...
1455 IF(iph == 0) THEN
1456 iph=1
1457 WRITE(*,101)
1458 END IF
1459 itgbi=globalparvartototal(ivgbi)
1460 itgbl=globalparlabelindex(1,itgbi)
1461
1462 globalvector=0.0_mpd ! reset rhs vector IGVEC
1463 globalvector(ivgbi)=1.0_mpd
1464
1465 ! NOUT =6
1466 nout =0
1467 itnlim=200
1468 shift =0.0_mpd
1469 rtol = mrestl ! from steering
1470 checka=.false.
1471
1472
1473 IF(mbandw == 0) THEN ! default preconditioner
1474 CALL minres(nagb, avprod, mcsolv, globalvector, shift, checka ,.true. , &
1475 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1476
1477 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1478 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.true. , &
1479 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1480 ELSE
1481 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.false. , &
1482 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1483 END IF
1484
1485 par=real(globalparameter(itgbi),mps)
1486 dpa=real(par-globalparstart(itgbi),mps)
1487 gmati=globalcorrections(ivgbi)
1488 err=sqrt(abs(real(gmati,mps)))
1489 IF(gmati < 0.0_mpd) err=-err
1490 diag=matij(ivgbi,ivgbi)
1491 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1492 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1493101 FORMAT(1x,' label parameter presigma differ', &
1494 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1495102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1496END SUBROUTINE solglo
1497
1504
1505SUBROUTINE solgloqlp(ivgbi)
1506 USE mpmod
1507 USE minresqlpmodule, ONLY: minresqlp
1508
1509 IMPLICIT NONE
1510 REAL(mps) :: par
1511 REAL(mps) :: dpa
1512 REAL(mps) :: err
1513 REAL(mps) :: gcor2
1514 INTEGER(mpi) :: iph
1515 INTEGER(mpi) :: istop
1516 INTEGER(mpi) :: itgbi
1517 INTEGER(mpi) :: itgbl
1518 INTEGER(mpi) :: itn
1519 INTEGER(mpi) :: itnlim
1520 INTEGER(mpi) :: nout
1521
1522 INTEGER(mpi), INTENT(IN) :: ivgbi
1523
1524 REAL(mpd) :: shift
1525 REAL(mpd) :: rtol
1526 REAL(mpd) :: mxxnrm
1527 REAL(mpd) :: trcond
1528 REAL(mpd) :: gmati
1529 REAL(mpd) :: diag
1530 REAL(mpd) :: matij
1531
1532 EXTERNAL avprod, mcsolv, mvsolv
1533 SAVE
1534 DATA iph/0/
1535 ! ...
1536 IF(iph == 0) THEN
1537 iph=1
1538 WRITE(*,101)
1539 END IF
1540 itgbi=globalparvartototal(ivgbi)
1541 itgbl=globalparlabelindex(1,itgbi)
1542
1543 globalvector=0.0_mpd ! reset rhs vector IGVEC
1544 globalvector(ivgbi)=1.0_mpd
1545
1546 ! NOUT =6
1547 nout =0
1548 itnlim=200
1549 shift =0.0_mpd
1550 rtol = mrestl ! from steering
1551 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
1552 IF(mrmode == 1) THEN
1553 trcond = 1.0_mpd/epsilon(trcond) ! only QR
1554 ELSE IF(mrmode == 2) THEN
1555 trcond = 1.0_mpd ! only QLP
1556 ELSE
1557 trcond = mrtcnd ! QR followed by QLP
1558 END IF
1559
1560 IF(mbandw == 0) THEN ! default preconditioner
1561 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mcsolv, nout=nout, &
1562 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1563 x=globalcorrections, istop=istop, itn=itn)
1564 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1565 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mvsolv, nout=nout, &
1566 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1567 x=globalcorrections, istop=istop, itn=itn)
1568 ELSE
1569 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, nout=nout, &
1570 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1571 x=globalcorrections, istop=istop, itn=itn)
1572 END IF
1573
1574 par=real(globalparameter(itgbi),mps)
1575 dpa=real(par-globalparstart(itgbi),mps)
1576 gmati=globalcorrections(ivgbi)
1577 err=sqrt(abs(real(gmati,mps)))
1578 IF(gmati < 0.0_mpd) err=-err
1579 diag=matij(ivgbi,ivgbi)
1580 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1581 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1582101 FORMAT(1x,' label parameter presigma differ', &
1583 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1584102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1585END SUBROUTINE solgloqlp
1586
1588SUBROUTINE addcst
1589 USE mpmod
1590
1591 IMPLICIT NONE
1592 REAL(mpd) :: climit
1593 REAL(mpd) :: factr
1594 REAL(mpd) :: sgm
1595
1596 INTEGER(mpi) :: i
1597 INTEGER(mpi) :: icgb
1598 INTEGER(mpi) :: irhs
1599 INTEGER(mpi) :: itgbi
1600 INTEGER(mpi) :: ivgb
1601 INTEGER(mpi) :: j
1602 INTEGER(mpi) :: jcgb
1603 INTEGER(mpi) :: l
1604 INTEGER(mpi) :: label
1605 INTEGER(mpi) :: nop
1606 INTEGER(mpi) :: inone
1607
1608 REAL(mpd) :: rhs
1609 REAL(mpd) :: drhs(4)
1610 INTEGER(mpi) :: idrh (4)
1611 SAVE
1612 ! ...
1613 nop=0
1614 IF(lenconstraints == 0) RETURN ! no constraints
1615 climit=1.0e-5 ! limit for printout
1616 irhs=0 ! number of values in DRHS(.), to be printed
1617
1618 DO jcgb=1,ncgb
1619 icgb=matconssort(3,jcgb) ! unsorted constraint index
1620 i=vecconsstart(icgb)
1621 rhs=listconstraints(i )%value ! right hand side
1622 sgm=listconstraints(i+1)%value ! sigma parameter
1623 DO j=i+2,vecconsstart(icgb+1)-1
1624 label=listconstraints(j)%label
1625 factr=listconstraints(j)%value
1626 itgbi=inone(label) ! -> ITGBI= index of parameter label
1627 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
1628
1629 IF(icalcm == 1.AND.nagb > nvgb.AND.ivgb > 0) THEN
1630 CALL mupdat(nvgb+jcgb,ivgb,factr) ! add to matrix
1631 END IF
1632
1633 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
1634 END DO
1635 IF(abs(rhs) > climit) THEN
1636 irhs=irhs+1
1637 idrh(irhs)=jcgb
1638 drhs(irhs)=rhs
1639 nop=1
1640 IF(irhs == 4) THEN
1641 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1642 irhs=0
1643 END IF
1644 END IF
1645 vecconsresiduals(jcgb)=rhs
1646 IF (nagb > nvgb) globalvector(nvgb+jcgb)=rhs
1647 END DO
1648
1649 IF(irhs /= 0) THEN
1650 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1651 END IF
1652 IF(nop == 0) RETURN
1653 WRITE(*,102) ' Constraints: only equation values >', climit,' are printed'
1654101 FORMAT(' ',4(i6,g11.3))
1655102 FORMAT(a,g11.2,a)
1656END SUBROUTINE addcst
1657
1662SUBROUTINE grpcon
1663 USE mpmod
1664 USE mpdalc
1665
1666 IMPLICIT NONE
1667 INTEGER(mpi) :: i
1668 INTEGER(mpi) :: icgb
1669 INTEGER(mpi) :: icgrp
1670 INTEGER(mpi) :: ioff
1671 INTEGER(mpi) :: itgbi
1672 INTEGER(mpi) :: j
1673 INTEGER(mpi) :: jcgb
1674 INTEGER(mpi) :: label
1675 INTEGER(mpi) :: labelf
1676 INTEGER(mpi) :: labell
1677 INTEGER(mpi) :: last
1678 INTEGER(mpi) :: line1
1679 INTEGER(mpi) :: ncon
1680 INTEGER(mpi) :: ndiff
1681 INTEGER(mpi) :: npar
1682 INTEGER(mpi) :: inone
1683 INTEGER(mpi) :: itype
1684 INTEGER(mpi) :: ncgbd
1685 INTEGER(mpi) :: ncgbr
1686 INTEGER(mpi) :: ncgbw
1687 INTEGER(mpi) :: ncgrpd
1688 INTEGER(mpi) :: ncgrpr
1689 INTEGER(mpi) :: next
1690
1691 INTEGER(mpl):: length
1692 INTEGER(mpl) :: rows
1693
1694 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsOffsets
1695 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsList
1696 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParOffsets
1697 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParList
1698 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1699
1700 ncgb=0
1701 ncgbw=0
1702 IF(lenconstraints == 0) RETURN ! no constraints
1703
1704 i=0
1705 last=0
1706 itype=0
1707 ! find next constraint header and count nr of constraints
1708 DO WHILE(i < lenconstraints)
1709 i=i+1
1710 label=listconstraints(i)%label
1711 IF(last < 0.AND.label < 0) THEN
1712 ncgb=ncgb+1
1713 itype=-label
1714 IF(itype == 2) ncgbw=ncgbw+1
1715 END IF
1716 last=label
1717 IF(label > 0) THEN
1718 itgbi=inone(label) ! -> ITGBI= index of parameter label
1719 globalparcons(itgbi)=globalparcons(itgbi)+1
1720 END IF
1721 IF(label > 0.AND.itype == 2) THEN ! weighted constraints
1722 itgbi=inone(label) ! -> ITGBI= index of parameter label
1724 END IF
1725 END DO
1726
1727 WRITE(*,*)
1728 IF (ncgbw == 0) THEN
1729 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files'
1730 ELSE
1731 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files,',ncgbw, 'weighted'
1732 END IF
1733 WRITE(*,*)
1734
1735 ! keys and index for sorting of constraints
1736 length=ncgb+1; rows=3
1737 CALL mpalloc(matconssort,rows,length,'keys and index for sorting (I)')
1738 matconssort(1,ncgb+1)=ntgb+1
1739 ! start of constraint in list
1740 CALL mpalloc(vecconsstart,length,'start of constraint in list (I)')
1742 ! start and parameter range of constraint groups
1743 CALL mpalloc(matconsgroups,rows,length,'start of constraint groups, par. range (I)')
1744 ! parameter ranges (all, variable) of constraints
1745 length=ncgb; rows=4
1746 CALL mpalloc(matconsranges,rows,length,'parameter ranges for constraint (I)')
1747
1748 length=ncgb; rows=3
1749 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
1750 matconsgroupindex=0
1751 length=ncgb+1
1752 CALL mpalloc(vecconsparoffsets,length,'offsets for global par list for cons. (I)')
1753 length=ntgb+1
1754 CALL mpalloc(vecparconsoffsets,length,'offsets for cons. list for global par. (I)')
1755 vecparconsoffsets(1)=0
1756 DO i=1,ntgb
1757 vecparconsoffsets(i+1)=vecparconsoffsets(i)+globalparcons(i)
1758 END DO
1760
1761 length=vecparconsoffsets(ntgb+1)
1762 CALL mpalloc(vecconsparlist,length,'global par. list for constraint (I)')
1763 CALL mpalloc(vecparconslist,length,'constraint list for global par. (I)')
1764
1765 ! prepare
1766 i=1
1767 ioff=0
1768 vecconsparoffsets(1)=ioff
1769 DO icgb=1,ncgb
1770 ! new constraint
1771 vecconsstart(icgb)=i
1772 line1=-listconstraints(i)%label
1773 npar=0
1774 i=i+2
1775 DO
1776 label=listconstraints(i)%label
1777 itgbi=inone(label) ! -> ITGBI= index of parameter label
1778 ! list of constraints for 'itgbi'
1779 globalparcons(itgbi)=globalparcons(itgbi)+1
1780 vecparconslist(vecparconsoffsets(itgbi)+globalparcons(itgbi))=icgb
1781 npar=npar+1
1782 vecconsparlist(ioff+npar)=itgbi
1783 i=i+1
1784 IF(i > lenconstraints) EXIT
1785 IF(listconstraints(i)%label < 0) EXIT
1786 END DO
1787 ! sort to find duplicates
1788 CALL sort1k(vecconsparlist(ioff+1),npar)
1789 last=-1
1790 ndiff=0
1791 DO j=1,npar
1792 next=vecconsparlist(ioff+j)
1793 IF (next /= last) THEN
1794 ndiff=ndiff+1
1795 vecconsparlist(ioff+ndiff) = next
1796 END IF
1797 last=next
1798 END DO
1799 matconsranges(1,icgb)=vecconsparlist(ioff+1) ! min parameter
1800 matconsranges(3,icgb)=vecconsparlist(ioff+1) ! min parameter
1801 ioff=ioff+ndiff
1802 matconsranges(2,icgb)=vecconsparlist(ioff) ! max parameter
1803 matconsranges(4,icgb)=vecconsparlist(ioff) ! max parameter
1804 vecconsparoffsets(icgb+1)=ioff
1805 END DO
1807
1808 ! sort (by first, last parameter)
1809 DO icgb=1,ncgb
1810 matconssort(1,icgb)=matconsranges(1,icgb) ! first par.
1811 matconssort(2,icgb)=matconsranges(2,icgb) ! last par.
1812 matconssort(3,icgb)=icgb ! index
1813 END DO
1814 CALL sort2i(matconssort,ncgb)
1815
1816 IF (icheck>1) THEN
1817 print *, ' Constraint #parameters first par. last par. first line'
1818 END IF
1819 ! split into disjoint groups
1820 ncgrp=0
1822 DO jcgb=1,ncgb
1823 icgb=matconssort(3,jcgb)
1824 IF (icheck>0) THEN
1825 npar=vecconsparoffsets(icgb+1)-vecconsparoffsets(icgb)
1826 line1=-listconstraints(vecconsstart(icgb))%label
1827 labelf=globalparlabelindex(1,matconsranges(1,icgb))
1828 labell=globalparlabelindex(1,matconsranges(2,icgb))
1829 print *, jcgb, npar, labelf, labell, line1
1830 END IF
1831 ! already part of group?
1832 icgrp=matconsgroupindex(1,icgb)
1833 IF (icgrp == 0) THEN
1834 ! check all parameters
1835 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1836 itgbi=vecconsparlist(i)
1837 ! check all related constraints
1838 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1839 icgrp=matconsgroupindex(1,vecparconslist(j))
1840 ! already part of group?
1841 IF (icgrp > 0) EXIT
1842 END DO
1843 IF (icgrp > 0) EXIT
1844 END DO
1845 IF (icgrp == 0) THEN
1846 ! new group
1847 ncgrp=ncgrp+1
1848 icgrp=ncgrp
1849 END IF
1850 END IF
1851 ! add to group
1852 matconsgroupindex(2,icgb)=jcgb
1853 matconsgroupindex(3,icgb)=icgb
1854 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1855 itgbi=vecconsparlist(i)
1856 globalparcons(itgbi)=icgrp
1857 ! mark all related constraints
1858 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1859 matconsgroupindex(1,vecparconslist(j))=icgrp
1860 END DO
1861 END DO
1862 END DO
1863 WRITE(*,*) 'GRPCON:',ncgrp,' disjoint constraints groups built'
1864
1865 ! sort by group number
1866 CALL sort2i(matconsgroupindex,ncgb)
1867
1868 matconsgroups(1,1:ncgrp)=0
1869 DO jcgb=1,ncgb
1870 ! set up matConsSort
1871 icgb=matconsgroupindex(3,jcgb)
1872 matconssort(1,jcgb)=matconsranges(1,icgb)
1873 matconssort(2,jcgb)=matconsranges(2,icgb)
1874 matconssort(3,jcgb)=icgb
1875 ! set up matConsGroups
1876 icgrp=matconsgroupindex(1,jcgb)
1877 IF (matconsgroups(1,icgrp) == 0) THEN
1878 matconsgroups(1,icgrp)=jcgb
1879 matconsgroups(2,icgrp)=matconsranges(1,icgb)
1880 matconsgroups(3,icgrp)=matconsranges(2,icgb)
1881 ELSE
1882 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
1883 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
1884 END IF
1885 END DO
1886 matconsgroups(1,ncgrp+1)=ncgb+1
1887 matconsgroups(2,ncgrp+1)=ntgb+1
1888
1889 ! check for redundancy constraint groups
1890 ncgbr=0
1891 ncgrpr=0
1892 ncgbd=0
1893 ncgrpd=0
1894 IF (icheck>0) THEN
1895 print *
1896 print *, ' cons.group first con. first par. last par. #cons #par'
1897 ENDIF
1898 DO icgrp=1,ncgrp
1899 npar=0
1900 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1901 IF (globalparcons(i) == icgrp) npar=npar+1
1902 END DO
1903 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
1904 IF (icheck>0) THEN
1905 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1906 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1907 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ncon, npar
1908 END IF
1909 ! redundancy constraints?
1910 IF (ncon == npar) THEN
1911 IF (irslvrc > 0) THEN
1912 ncgrpr=ncgrpr+1
1913 ncgbr=ncgbr+ncon
1914 IF (icheck > 0) THEN
1915 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1916 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1917 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group resolved'
1918 END IF
1919 ! flag redundant parameters
1920 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1921 IF (globalparcons(i) == icgrp) globalparcons(i)=-icgrp
1922 END DO
1923 ! flag constraint group
1924 matconsgroups(2,icgrp)=ntgb+1
1925 matconsgroups(3,icgrp)=ntgb
1926 ELSE
1927 ncgrpd=ncgrpd+1
1928 ncgbd=ncgbd+ncon
1929 IF (icheck > 0) THEN
1930 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1931 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1932 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group redundant'
1933 END IF
1934 END IF
1935 END IF
1936 END DO
1937 IF (ncgrpr > 0) THEN
1938 WRITE(*,*) 'GRPCON:',ncgbr,' redundancy constraints in ', ncgrpr, ' groups resolved'
1939 ! all constraint groups resolved ?
1940 IF (ncgrpr == ncgrp) ncgrp=0
1941 ENDIF
1942 IF (ncgrpd > 0) THEN
1943 WRITE(*,*) 'GRPCON:',ncgbd,' redundancy constraints in ', ncgrpd, ' groups detected'
1944 ENDIF
1945 WRITE(*,*)
1946
1947 ! clean up
1948 CALL mpdealloc(vecparconslist)
1949 CALL mpdealloc(vecconsparlist)
1950 CALL mpdealloc(vecparconsoffsets)
1951 CALL mpdealloc(vecconsparoffsets)
1952 CALL mpdealloc(matconsgroupindex)
1953
1954END SUBROUTINE grpcon
1955
1959
1960SUBROUTINE prpcon
1961 USE mpmod
1962 USE mpdalc
1963
1964 IMPLICIT NONE
1965 INTEGER(mpi) :: i
1966 INTEGER(mpi) :: icgb
1967 INTEGER(mpi) :: icgrp
1968 INTEGER(mpi) :: ifrst
1969 INTEGER(mpi) :: ilast
1970 INTEGER(mpi) :: isblck
1971 INTEGER(mpi) :: itgbi
1972 INTEGER(mpi) :: ivgb
1973 INTEGER(mpi) :: j
1974 INTEGER(mpi) :: jcgb
1975 INTEGER(mpi) :: jfrst
1976 INTEGER(mpi) :: label
1977 INTEGER(mpi) :: labelf
1978 INTEGER(mpi) :: labell
1979 INTEGER(mpi) :: ncon
1980 INTEGER(mpi) :: ngrp
1981 INTEGER(mpi) :: npar
1982 INTEGER(mpi) :: ncnmxb
1983 INTEGER(mpi) :: ncnmxg
1984 INTEGER(mpi) :: nprmxb
1985 INTEGER(mpi) :: nprmxg
1986 INTEGER(mpi) :: inone
1987 INTEGER(mpi) :: nvar
1988
1989 INTEGER(mpl):: length
1990 INTEGER(mpl) :: rows
1991
1992 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1993
1994 ncgbe=0
1995 !
1996 ! constraint groups already built in GRPCON based on steering,
1997 ! now care about fixed parameters
1998 !
1999 IF(ncgrp == 0) THEN ! no constraints groups
2000 ncgb=0
2001 ncblck=0
2002 RETURN
2003 END IF
2004
2005 length=ncgrp+1; rows=3
2006 ! start and parameter range of constraint blocks
2007 CALL mpalloc(matconsblocks,rows,length,'start of constraint blocks, par. range (I)')
2008
2009 length=ncgb; rows=3
2010 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
2011 matconsgroupindex=0
2012
2013 ! check for empty constraints, redefine (accepted/active) constraints and groups
2014 ngrp=0
2015 ncgb=0
2016 DO icgrp=1,ncgrp
2017 ncon=ncgb
2018 ! resolved group ?
2019 IF (matconsgroups(2,icgrp) > matconsgroups(3,icgrp)) cycle
2020 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2021 icgb=matconssort(3,jcgb)
2022 i=vecconsstart(icgb)+2
2023 npar=0
2024 nvar=0
2025 matconsranges(1,icgb)=ntgb
2026 matconsranges(2,icgb)=1
2027 DO
2028 label=listconstraints(i)%label
2029 itgbi=inone(label) ! -> ITGBI= index of parameter label
2030 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2031 npar=npar+1
2032 IF(ivgb > 0) THEN
2033 nvar=nvar+1
2034 matconsranges(1,icgb)=min(matconsranges(1,icgb),itgbi)
2035 matconsranges(2,icgb)=max(matconsranges(2,icgb),itgbi)
2036 ENDIF
2037 i=i+1
2038 IF(i > lenconstraints) EXIT
2039 IF(listconstraints(i)%label < 0) EXIT
2040 END DO
2041 IF (nvar == 0) THEN
2042 ncgbe=ncgbe+1
2043 ! reset range
2044 matconsranges(1,icgb)=matconsranges(3,icgb)
2045 matconsranges(2,icgb)=matconsranges(4,icgb)
2046 END IF
2047 IF (nvar > 0 .OR. iskpec == 0) THEN
2048 ! constraint accepted (or kept)
2049 ncgb=ncgb+1
2050 matconsgroupindex(1,ncgb)=ngrp+1
2051 matconsgroupindex(2,ncgb)=icgb
2052 matconsgroupindex(3,ncgb)=nvar
2053 END IF
2054 END DO
2055 IF (ncgb > ncon) ngrp=ngrp+1
2056 END DO
2057 ncgrp=ngrp
2058
2059 IF (ncgbe > 0) THEN
2060 IF (iskpec > 0) THEN
2061 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints skipped'
2062 ELSE
2063 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints detected, to be fixed !!!'
2064 WRITE(*,*) ' (use option "skipemptycons" to skip those)'
2065 IF (icheck == 0) THEN
2066 icheck=2 ! switch to '-C'
2067 ncgbe=-ncgbe ! indicate that
2068 WRITE(*,*)
2069 WRITE(*,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2070 WRITE(8,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2071 WRITE(*,*)
2072 END IF
2073 END IF
2074 END IF
2075 WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted'
2076 WRITE(*,*)
2077
2078 IF(ncgb == 0) RETURN ! no constraints left
2079
2080 ! already sorted by group number
2081
2082 matconsgroups(1,1:ncgrp)=0
2083 DO jcgb=1,ncgb
2084 ! set up matConsSort
2085 icgb=matconsgroupindex(2,jcgb)
2086 matconssort(1,jcgb)=matconsranges(1,icgb)
2087 matconssort(2,jcgb)=matconsranges(2,icgb)
2088 matconssort(3,jcgb)=icgb
2089 ! set up matConsGroups
2090 icgrp=matconsgroupindex(1,jcgb)
2091 IF (matconsgroups(1,icgrp) == 0) THEN
2092 matconsgroups(1,icgrp)=jcgb
2093 matconsgroups(2,icgrp)=matconsranges(1,icgb)
2094 matconsgroups(3,icgrp)=matconsranges(2,icgb)
2095 ELSE
2096 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
2097 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
2098 END IF
2099 END DO
2100 matconsgroups(1,ncgrp+1)=ncgb+1
2101 matconsgroups(2,ncgrp+1)=ntgb+1
2102
2103 ! loop over constraints groups, combine into non overlapping blocks
2104 ncblck=0
2105 ncnmxg=0
2106 nprmxg=0
2107 ncnmxb=0
2108 nprmxb=0
2109 mszcon=0
2110 mszprd=0
2111 isblck=1
2112 ilast=0
2113 IF (icheck > 0) THEN
2114 WRITE(*,*)
2115 IF (icheck > 1) &
2116 WRITE(*,*) ' Cons. sorted index #var.par. first line first label last label'
2117 WRITE(*,*) ' Cons. group index first cons. last cons. first label last label'
2118 WRITE(*,*) ' Cons. block index first group last group first label last label'
2119 END IF
2120 DO icgrp=1,ncgrp
2121 IF (icheck > 1) THEN
2122 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2123 icgb=matconssort(3,jcgb)
2124 nvar=matconsgroupindex(3,jcgb)
2125 labelf=globalparlabelindex(1,matconssort(1,jcgb))
2126 labell=globalparlabelindex(1,matconssort(2,jcgb))
2127 IF (nvar > 0) THEN
2128 WRITE(*,*) ' Cons. sorted', jcgb, nvar, &
2129 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2130 ELSE
2131 WRITE(*,*) ' Cons. sorted', jcgb, ' empty (0)', &
2132 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2133 END IF
2134 END DO
2135 END IF
2136 IF (icheck > 0) THEN
2137 !ivgb=globalParLabelIndex(2,matConsGroups(2,icgrp)) ! -> index of variable global parameter
2138 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
2139 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
2140 WRITE(*,*) ' Cons. group ', icgrp, matconsgroups(1,icgrp), &
2141 matconsgroups(1,icgrp+1)-1, labelf, labell
2142 ENDIF
2143 ! combine into non overlapping blocks
2144 ilast=max(ilast, matconsgroups(3,icgrp))
2145 IF (matconsgroups(2,icgrp+1) > ilast) THEN
2146 ncblck=ncblck+1
2147 ifrst=matconsgroups(2,isblck)
2149 matconsblocks(2,ncblck)=ifrst ! save first parameter in block
2150 matconsblocks(3,ncblck)=ilast ! save last parameter in block
2151 ! update matConsSort
2152 jfrst=matconsgroups(2,icgrp)
2153 DO i=icgrp,isblck,-1
2154 DO j=matconsgroups(1,i),matconsgroups(1,i+1)-1
2155 ! non zero range (from group)
2156 matconsranges(1,j)=matconsgroups(2,i)
2158 ! storage range (from max group, ilast)
2159 jfrst=min(jfrst,matconsgroups(2,i))
2160 matconsranges(3,j)=jfrst
2161 matconsranges(4,j)=ilast
2162 END DO
2163 END DO
2164 IF (icheck > 0) THEN
2165 labelf=globalparlabelindex(1,ifrst)
2166 labell=globalparlabelindex(1,ilast)
2167 WRITE(*,*) ' Cons. block ', ncblck, isblck, icgrp, labelf, labell
2168 ENDIF
2169 ! reset for new block
2170 isblck=icgrp+1
2171 END IF
2172 END DO
2174
2175 ! convert from total parameter index to index of variable global parameter
2176 DO i=1,ncblck
2177 ifrst=globalparlabelindex(2,matconsblocks(2,i)) ! -> index of variable global parameter
2178 ilast=globalparlabelindex(2,matconsblocks(3,i)) ! -> index of variable global parameter
2179 IF (ifrst > 0) THEN
2180 matconsblocks(2,i)=ifrst
2181 matconsblocks(3,i)=ilast
2182 ! statistics
2183 ncon=matconsblocks(1,i+1)-matconsblocks(1,i)
2184 npar=ilast+1-ifrst
2185 ncnmxb=max(ncnmxb,ncon)
2186 nprmxb=max(nprmxb,npar)
2187 ! update index ranges
2188 globalindexranges(ifrst)=max(globalindexranges(ifrst),ilast)
2189 ELSE
2190 ! empty
2191 matconsblocks(2,i)=1
2192 matconsblocks(3,i)=0
2193 END IF
2194 END DO
2195 DO icgrp=1,ncgrp
2196 ifrst=globalparlabelindex(2,matconsgroups(2,icgrp)) ! -> index of variable global parameter
2197 ilast=globalparlabelindex(2,matconsgroups(3,icgrp)) ! -> index of variable global parameter
2198 IF (ifrst > 0) THEN
2199 matconsgroups(2,icgrp)=ifrst
2200 matconsgroups(3,icgrp)=ilast
2201 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2202 DO i=1,4
2203 ivgb=globalparlabelindex(2,matconsranges(i,jcgb)) ! -> index of variable global parameter
2204 matconsranges(i,jcgb)=ivgb
2205 END DO
2206 END DO
2207 ! storage sizes, statistics
2208 jcgb=matconsgroups(1,icgrp) ! first cons.
2209 ncon=matconsgroups(1,icgrp+1)-jcgb
2210 npar=matconsranges(4,jcgb)+1-matconsranges(3,jcgb)
2211 ncnmxg=max(ncnmxg,ncon)
2212 nprmxg=max(nprmxg,npar)
2213 mszcon=mszcon+int(ncon,mpl)*int(npar,mpl) ! (sum of) block size for constraint matrix
2214 mszprd=mszprd+int(ncon,mpl)*int(ncon+1,mpl)/2 ! (sum of) block size for product matrix
2215 ELSE
2216 ! empty
2217 matconsgroups(2,icgrp)=1
2218 matconsgroups(3,icgrp)=0
2219 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2220 matconsranges(1,jcgb)=1
2221 matconsranges(2,jcgb)=0
2222 matconsranges(3,jcgb)=1
2223 matconsranges(4,jcgb)=0
2224 END DO
2225 END IF
2226 END DO
2227
2228 ! clean up
2229 CALL mpdealloc(matconsgroupindex)
2230
2231 ! save constraint group for global parameters
2233 DO icgrp=1,ncgrp
2234 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2235 ! index in list
2236 icgb=matconssort(3,jcgb)
2237 DO j=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
2238 label=listconstraints(j)%label
2239 itgbi=inone(label) ! -> ITGBI= index of parameter label
2240 globalparcons(itgbi)=icgrp ! save constraint group
2241 END DO
2242 END DO
2243 END DO
2244
2245 IF (ncgrp+icheck > 1) THEN
2246 WRITE(*,*)
2247 WRITE(*,*) 'PRPCON: constraints split into ', ncgrp, '(disjoint) groups,'
2248 WRITE(*,*) ' groups combined into ', ncblck, '(non overlapping) blocks'
2249 WRITE(*,*) ' max group size (cons., par.) ', ncnmxg, nprmxg
2250 WRITE(*,*) ' max block size (cons., par.) ', ncnmxb, nprmxb
2251 IF (icheck > 0) WRITE(*,*) ' total block matrix sizes ', mszcon, mszprd
2252 END IF
2253
2254END SUBROUTINE prpcon
2255
2259
2260SUBROUTINE feasma
2261 USE mpmod
2262 USE mpdalc
2263
2264 IMPLICIT NONE
2265 REAL(mpd) :: factr
2266 REAL(mpd) :: sgm
2267 INTEGER(mpi) :: i
2268 INTEGER(mpi) :: icgb
2269 INTEGER(mpi) :: icgrp
2270 INTEGER(mpl) :: ij
2271 INTEGER(mpi) :: ifirst
2272 INTEGER(mpi) :: ilast
2273 INTEGER(mpl) :: ioffc
2274 INTEGER(mpl) :: ioffp
2275 INTEGER(mpi) :: irank
2276 INTEGER(mpi) :: ipar0
2277 INTEGER(mpi) :: itgbi
2278 INTEGER(mpi) :: ivgb
2279 INTEGER(mpi) :: j
2280 INTEGER(mpi) :: jcgb
2281 INTEGER(mpl) :: ll
2282 INTEGER(mpi) :: label
2283 INTEGER(mpi) :: ncon
2284 INTEGER(mpi) :: npar
2285 INTEGER(mpi) :: nrank
2286 INTEGER(mpi) :: inone
2287
2288 REAL(mpd):: rhs
2289 REAL(mpd):: evmax
2290 REAL(mpd):: evmin
2291 INTEGER(mpl):: length
2292 REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConstraintsT
2293 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
2294 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
2295 SAVE
2296 ! ...
2297
2298 IF(ncgb == 0) RETURN ! no constraints
2299
2300 ! product matrix A A^T (A is stored as transposed)
2301 length=mszprd
2302 CALL mpalloc(matconsproduct, length, 'product matrix of constraints (blocks)')
2303 matconsproduct=0.0_mpd
2304 length=ncgb
2305 CALL mpalloc(vecconsresiduals, length, 'residuals of constraints')
2306 CALL mpalloc(vecconssolution, length, 'solution for constraints')
2307 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
2308 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
2309 ! constraint matrix A (A is stored as transposed)
2310 length = mszcon
2311 CALL mpalloc(matconstraintst,length,'transposed matrix of constraints (blocks)')
2312 matconstraintst=0.0_mpd
2313
2314 ! loop over sorted constraints, fill matrices, get rank, inverted product matrix (in groups)
2315 ioffc=0 ! group offset in constraint matrix
2316 ioffp=0 ! group offset in product matrix
2317 nrank=0
2318 DO icgrp=1,ncgrp
2319 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2320 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2321 ncon=ilast+1-ifirst
2322 ipar0=matconsranges(3,ifirst)-1 ! parameter offset
2323 npar=matconsranges(4,ifirst)-ipar0 ! number of parameters
2324 IF (npar <= 0) THEN
2325 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, 0, ' (empty)'
2326 cycle ! skip empty groups/cons.
2327 END IF
2328 DO jcgb=ifirst,ilast
2329 ! index in list
2330 icgb=matconssort(3,jcgb)
2331 ! fill constraint matrix
2332 i=vecconsstart(icgb)
2333 rhs=listconstraints(i )%value ! right hand side
2334 sgm=listconstraints(i+1)%value ! sigma parameter
2335 DO j=i+2,vecconsstart(icgb+1)-1
2336 label=listconstraints(j)%label
2337 factr=listconstraints(j)%value
2338 itgbi=inone(label) ! -> ITGBI= index of parameter label
2339 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2340 IF(ivgb > 0) matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)= &
2341 matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)+factr ! matrix element
2342 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2343 END DO
2344 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2345 END DO
2346
2347 ! get rank of groups
2348 DO ll=ioffc+1,ioffc+npar
2349 ij=ioffp
2350 DO i=1,ncon
2351 DO j=1,i
2352 ij=ij+1
2353 matconsproduct(ij)=matconsproduct(ij)+ &
2354 matconstraintst(int(i-1,mpl)*int(npar,mpl)+ll)* &
2355 matconstraintst(int(j-1,mpl)*int(npar,mpl)+ll)
2356 END DO
2357 END DO
2358 END DO
2359 ! inversion of product matrix of constraints
2360 CALL sqminv(matconsproduct(ioffp+1:ij),vecconsresiduals(ifirst:ilast),ncon,irank, auxvectord, auxvectori)
2361 IF (icheck > 1 .OR. irank < ncon) THEN
2362 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, irank
2363 IF (irank < ncon) THEN
2364 WRITE(*,*) ' .. rank deficit !! '
2365 WRITE(*,*) ' E.g. fix all parameters and remove all constraints related to label ', &
2367 END IF
2368 END IF
2369 nrank=nrank+irank
2370 ioffc=ioffc+int(npar,mpl)*int(ncon,mpl)
2371 ioffp=ij
2372 END DO
2373
2374 nmiss1=ncgb-nrank
2375
2376 WRITE(*,*) ' '
2377 WRITE(*,*) 'Rank of product matrix of constraints is',nrank, &
2378 ' for',ncgb,' constraint equations'
2379 WRITE(8,*) 'Rank of product matrix of constraints is',nrank, &
2380 ' for',ncgb,' constraint equations'
2381 IF(nrank < ncgb) THEN
2382 WRITE(*,*) 'Warning: insufficient constraint equations!'
2383 WRITE(8,*) 'Warning: insufficient constraint equations!'
2384 IF (iforce == 0) THEN
2385 isubit=1
2386 WRITE(*,*) ' --> enforcing SUBITO mode'
2387 WRITE(8,*) ' --> enforcing SUBITO mode'
2388 END IF
2389 END IF
2390
2391 ! QL decomposition
2392 IF (nfgb < nvgb) THEN
2393 print *
2394 print *, 'QL decomposition of constraints matrix'
2395 ! monitor progress
2396 IF(monpg1 > 0) THEN
2397 WRITE(lunlog,*) 'QL decomposition of constraints matrix'
2399 END IF
2400 IF(icelim < 2) THEN ! True unless unpacked LAPACK
2401 ! QL decomposition
2403 ! loop over parameter blocks
2405 ! check eignevalues of L
2406 CALL qlgete(evmin,evmax)
2407#ifdef LAPACK64
2408 ELSE
2409 CALL lpqldec(matconstraintst,evmin,evmax)
2410#endif
2411 END IF
2412 IF(monpg1 > 0) CALL monend()
2413 print *, ' largest |eigenvalue| of L: ', evmax
2414 print *, ' smallest |eigenvalue| of L: ', evmin
2415 IF (evmin == 0.0_mpd.AND.icheck == 0) THEN
2416 CALL peend(27,'Aborted, singular QL decomposition of constraints matrix')
2417 stop 'FEASMA: stopping due to singular QL decomposition of constraints matrix'
2418 END IF
2419 END IF
2420
2421 CALL mpdealloc(matconstraintst)
2422 CALL mpdealloc(auxvectord)
2423 CALL mpdealloc(auxvectori)
2424
2425 RETURN
2426END SUBROUTINE feasma ! matrix for feasible solution
2427
2435SUBROUTINE feasib(concut,iact)
2436 USE mpmod
2437 USE mpdalc
2438
2439 IMPLICIT NONE
2440 REAL(mpd) :: factr
2441 REAL(mpd) :: sgm
2442 INTEGER(mpi) :: i
2443 INTEGER(mpi) :: icgb
2444 INTEGER(mpi) :: icgrp
2445 INTEGER(mpi) :: iter
2446 INTEGER(mpi) :: itgbi
2447 INTEGER(mpi) :: ivgb
2448 INTEGER(mpi) :: ieblck
2449 INTEGER(mpi) :: isblck
2450 INTEGER(mpi) :: ifirst
2451 INTEGER(mpi) :: ilast
2452 INTEGER(mpi) :: j
2453 INTEGER(mpi) :: jcgb
2454 INTEGER(mpi) :: label
2455 INTEGER(mpi) :: inone
2456 INTEGER(mpi) :: ncon
2457
2458 REAL(mps), INTENT(IN) :: concut
2459 INTEGER(mpi), INTENT(OUT) :: iact
2460
2461 REAL(mpd) :: rhs
2462 REAL(mpd) ::sum1
2463 REAL(mpd) ::sum2
2464 REAL(mpd) ::sum3
2465
2466 REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecCorrections
2467 SAVE
2468
2469 iact=0
2470 IF(ncgb == 0) RETURN ! no constraints
2471
2472 DO iter=1,2
2473 vecconsresiduals=0.0_mpd
2474
2475 ! calculate right constraint equation discrepancies
2476 DO jcgb=1,ncgb
2477 icgb=matconssort(3,jcgb) ! unsorted constraint index
2478 i=vecconsstart(icgb)
2479 rhs=listconstraints(i )%value ! right hand side
2480 sgm=listconstraints(i+1)%value ! sigma parameter
2481 DO j=i+2,vecconsstart(icgb+1)-1
2482 label=listconstraints(j)%label
2483 factr=listconstraints(j)%value
2484 itgbi=inone(label) ! -> ITGBI= index of parameter label
2485 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2486 ENDDO
2487 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2488 END DO
2489
2490 ! constraint equation discrepancies -------------------------------
2491
2492 sum1=0.0_mpd
2493 sum2=0.0_mpd
2494 sum3=0.0_mpd
2495 DO icgb=1,ncgb
2496 sum1=sum1+vecconsresiduals(icgb)**2
2497 sum2=sum2+abs(vecconsresiduals(icgb))
2498 sum3=max(sum3,abs(vecconsresiduals(icgb)))
2499 END DO
2500 sum1=sqrt(sum1/real(ncgb,mpd))
2501 sum2=sum2/real(ncgb,mpd)
2502
2503 IF(iter == 1.AND.sum1 < concut) RETURN ! do nothing if correction small
2504
2505 IF(iter == 1.AND.ncgb <= 12) THEN
2506 WRITE(*,*) ' '
2507 WRITE(*,*) 'Constraint equation discrepancies:'
2508 WRITE(*,101) (icgb,vecconsresiduals(icgb),icgb=1,ncgb)
2509101 FORMAT(4x,4(i5,g12.4))
2510 WRITE(*,103) concut
2511103 FORMAT(10x,' Cut on rms value is',g8.1)
2512 END IF
2513
2514 IF(iact == 0) THEN
2515 WRITE(*,*) ' '
2516 WRITE(*,*) 'Improve constraints'
2517 END IF
2518 iact=1
2519
2520 WRITE(*,102) iter,sum1,sum2,sum3
2521102 FORMAT(i6,' rms',g12.4,' avrg_abs',g12.4,' max_abs',g12.4)
2522
2523 CALL mpalloc(veccorrections,int(nvgb,mpl),'constraint corrections')
2524 veccorrections=0.0_mpd
2525
2526 ! multiply (group-wise) inverse matrix and constraint vector
2527 isblck=0
2528 DO icgrp=1,ncgrp
2529 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2530 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2531 ncon=ilast+1-ifirst
2532 ieblck=isblck+(ncon*(ncon+1))/2
2533 CALL dbsvx(matconsproduct(isblck+1:ieblck),vecconsresiduals(ifirst:ilast),vecconssolution(ifirst:ilast),ncon)
2534 isblck=ieblck
2535 END DO
2536
2537 DO jcgb=1,ncgb
2538 icgb=matconssort(3,jcgb) ! unsorted constraint index
2539 i=vecconsstart(icgb)
2540 rhs=listconstraints(i )%value ! right hand side
2541 sgm=listconstraints(i+1)%value ! sigma parameter
2542 DO j=i+2,vecconsstart(icgb+1)-1
2543 label=listconstraints(j)%label
2544 factr=listconstraints(j)%value
2545 itgbi=inone(label) ! -> ITGBI= index of parameter label
2546 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2547 IF(ivgb > 0) THEN
2548 veccorrections(ivgb)=veccorrections(ivgb)+vecconssolution(jcgb)*factr
2549 END IF
2550 ENDDO
2551 END DO
2552
2553 DO i=1,nvgb ! add corrections
2554 itgbi=globalparvartototal(i)
2555 globalparameter(itgbi)=globalparameter(itgbi)+veccorrections(i)
2556 END DO
2557
2558 CALL mpdealloc(veccorrections)
2559
2560 END DO ! iteration 1 and 2
2561
2562END SUBROUTINE feasib ! make parameters feasible
2563
2596SUBROUTINE peread(more)
2597 USE mpmod
2598
2599 IMPLICIT NONE
2600 INTEGER(mpi) :: i
2601 INTEGER(mpi) :: iact
2602 INTEGER(mpi) :: ierrc
2603 INTEGER(mpi) :: ierrf
2604 INTEGER(mpi) :: ioffp
2605 INTEGER(mpi) :: ios
2606 INTEGER(mpi) :: ithr
2607 INTEGER(mpi) :: jfile
2608 INTEGER(mpi) :: jrec
2609 INTEGER(mpi) :: k
2610 INTEGER(mpi) :: kfile
2611 INTEGER(mpi) :: l
2612 INTEGER(mpi) :: lun
2613 INTEGER(mpi) :: mpri
2614 INTEGER(mpi) :: n
2615 INTEGER(mpi) :: nact
2616 INTEGER(mpi) :: nbuf
2617 INTEGER(mpi) :: ndata
2618 INTEGER(mpi) :: noff
2619 INTEGER(mpi) :: noffs
2620 INTEGER(mpi) :: npointer
2621 INTEGER(mpi) :: npri
2622 INTEGER(mpi) :: nr
2623 INTEGER(mpi) :: nrc
2624 INTEGER(mpi) :: nrd
2625 INTEGER(mpi) :: nrpr
2626 INTEGER(mpi) :: nthr
2627 INTEGER(mpi) :: ntot
2628 INTEGER(mpi) :: maxRecordSize
2629 INTEGER(mpi) :: maxRecordFile
2630
2631 INTEGER(mpi), INTENT(OUT) :: more
2632
2633 LOGICAL :: lprint
2634 LOGICAL :: floop
2635 LOGICAL :: eof
2636 REAL(mpd) :: ds0
2637 REAL(mpd) :: ds1
2638 REAL(mpd) :: ds2
2639 REAL(mpd) :: dw
2640 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
2641 CHARACTER (LEN=7) :: cfile
2642 SAVE
2643
2644#ifdef READ_C_FILES
2645 INTERFACE
2646 SUBROUTINE readc(bufferD, bufferF, bufferI, bufferLength, lun, err) BIND(c)
2647 USE iso_c_binding
2648 REAL(c_double), DIMENSION(*), INTENT(OUT) :: bufferD
2649 REAL(c_float), DIMENSION(*), INTENT(OUT) :: bufferF
2650 INTEGER(c_int), DIMENSION(*), INTENT(OUT) :: bufferI
2651 INTEGER(c_int), INTENT(INOUT) :: bufferLength
2652 INTEGER(c_int), INTENT(IN), VALUE :: lun
2653 INTEGER(c_int), INTENT(OUT) :: err
2654 END SUBROUTINE readc
2655 END INTERFACE
2656#endif
2657
2658 DATA lprint/.true./
2659 DATA floop/.true./
2660 DATA npri / 0 /, mpri / 1000 /
2661 ! ...
2662 IF(ifile == 0) THEN ! start/restart
2663 nrec=0
2664 nrecd=0
2665 ntot=0
2666 sumrecords=0
2668 numblocks=0
2671 readbufferinfo=0 ! reset management info
2672 nrpr=1
2673 nthr=mthrdr
2674 nact=0 ! active threads (have something still to read)
2675 DO k=1,nthr
2676 IF (ifile < nfilb) THEN
2677 ifile=ifile+1
2679 readbufferinfo(2,k)=nact
2680 nact=nact+1
2681 END IF
2682 END DO
2683 END IF
2684 npointer=size(readbufferpointer)/nact
2685 ndata=size(readbufferdatai)/nact
2686 more=-1
2687 DO k=1,nthr
2688 iact=readbufferinfo(2,k)
2689 readbufferinfo(4,k)=0 ! reset counter
2690 readbufferinfo(5,k)=iact*ndata ! reset offset
2691 END DO
2692 numblocks=numblocks+1 ! new block
2693
2694 !$OMP PARALLEL &
2695 !$OMP DEFAULT(PRIVATE) &
2696 !$OMP SHARED(readBufferInfo,readBufferPointer,readBufferDataI,readBufferDataD, &
2697 !$OMP readBufferDataF,nPointer,nData,skippedRecords,ndimbuf,NTHR,NFILF,FLOOP, &
2698 !$OMP IFD,KFD,IFILE,NFILB,WFD,XFD,icheck,keepOpen,ireeof,nrderr) NUM_THREADS(NTHR)
2699 ! NUM_THREADS(NTHR) moved to previuos line to make OPARI2 used by scorep-8.4. happy
2700 ithr=1
2701 !$ ITHR=OMP_GET_THREAD_NUM()+1 ! thread number
2702 jfile=readbufferinfo(1,ithr) ! file index
2703 iact =readbufferinfo(2,ithr) ! active thread number
2704 jrec =readbufferinfo(3,ithr) ! records read
2705 ioffp=iact*npointer
2706 noffs=(ithr-1)*ndimbuf ! offset for intermediate float buffer
2707
2708 files: DO WHILE (jfile > 0)
2709 kfile=kfd(2,jfile)
2710 ! open again
2711 IF (keepopen < 1 .AND. readbufferinfo(3,ithr) == 0) THEN
2712 CALL binopn(kfile,ithr,ios)
2713 END IF
2714 records: DO
2715 nbuf=readbufferinfo(4,ithr)+1
2716 noff=readbufferinfo(5,ithr)+2 ! 2 header words per record
2717 nr=ndimbuf
2718 IF(kfile <= nfilf) THEN ! Fortran file
2719 lun=kfile+10
2720 READ(lun,iostat=ierrf) n,(readbufferdataf(noffs+i),i=1,min(n/2,nr)),&
2721 (readbufferdatai(noff+i),i=1,min(n/2,nr))
2722 nr=n/2
2723 ! convert to double
2724 IF (nr <= ndimbuf) THEN
2725 DO i=1,nr
2726 readbufferdatad(noff+i)=real(readbufferdataf(noffs+i),mpr8)
2727 END DO
2728 END IF
2729 ! IF (ierrf < 0) REWIND lun ! end-of-file ! CHK use binrwd()
2730 eof=(ierrf /= 0)
2731 ELSE ! C file
2732 lun=kfile-nfilf
2733 IF (keepopen < 1) lun=ithr
2734#ifdef READ_C_FILES
2735 CALL readc(readbufferdatad(noff+1),readbufferdataf(noffs+1),readbufferdatai(noff+1),nr,lun,ierrc)
2736 n=nr+nr
2737 IF (ierrc > 4) readbufferinfo(6,ithr)=readbufferinfo(6,ithr)+1
2738#else
2739 ierrc=0
2740#endif
2741 eof=(ierrc <= 0.AND.ierrc /= -4) ! allow buffer overruns -> skip record
2742 IF(eof.AND.ierrc < 0) THEN
2743 WRITE(*,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2744 WRITE(8,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2745 IF (icheck <= 0 .AND. ireeof <=0) THEN ! stop unless 'checkinput' mode or 'readerroraseof'
2746 WRITE(cfile,'(I7)') kfile
2747 CALL peend(18,'Aborted, read error(s) for binary file ' // cfile)
2748 stop 'PEREAD: stopping due to read errors (bad record, wrong file type?)'
2749 END IF
2750 IF (kfd(1,jfile) == 1) THEN ! count files with read errors in first loop
2751 !$OMP ATOMIC
2752 nrderr=nrderr+1
2753 END IF
2754 END IF
2755 END IF
2756 IF(eof) EXIT records ! end-of-files or error
2757
2758 jrec=jrec+1
2759 readbufferinfo(3,ithr)=jrec
2760 IF(floop) THEN
2761 xfd(jfile)=max(xfd(jfile),n)
2762 IF(ithr == 1) THEN
2763 CALL hmplnt(1,n)
2764 IF(readbufferdatai(noff+1) /= 0) CALL hmpent(8,real(readbufferdatai(noff+1),mps))
2765 END IF
2766 END IF
2767
2768 IF (nr <= ndimbuf) THEN
2769 readbufferinfo(4,ithr)=nbuf
2770 readbufferinfo(5,ithr)=noff+nr
2771
2772 readbufferpointer(ioffp+nbuf)=noff ! pointer to start of buffer
2773 readbufferdatai(noff )=noff+nr ! pointer to end of buffer
2774 readbufferdatai(noff-1)=jrec ! local record number
2775 readbufferdatad(noff )=real(kfile,mpr8) ! file number
2776 readbufferdatad(noff-1)=real(wfd(kfile),mpr8) ! weight
2777
2778 IF ((noff+nr+2+ndimbuf >= ndata*(iact+1)).OR.(nbuf >= npointer)) EXIT files ! buffer full
2779 ELSE
2780 !$OMP ATOMIC
2782 cycle records
2783 END IF
2784
2785 END DO records
2786
2787 readbufferinfo(1,ithr)=-jfile ! flag eof
2788 IF (keepopen < 1) THEN ! close again
2789 CALL bincls(kfile,ithr)
2790 ELSE ! rewind
2791 CALL binrwd(kfile)
2792 END IF
2793 IF (kfd(1,jfile) == 1) THEN
2794 print *, 'PEREAD: file ', kfile, 'read the first time, found',jrec,' records'
2795 kfd(1,jfile)=-jrec
2796 ELSE
2797 !PRINT *, 'PEREAD: file ', kfile, 'records', jrec, -kfd(1,jfile)
2798 IF (-kfd(1,jfile) /= jrec) THEN
2799 WRITE(cfile,'(I7)') kfile
2800 CALL peend(19,'Aborted, binary file modified (length) ' // cfile)
2801 stop 'PEREAD: file modified (length)'
2802 END IF
2803 END IF
2804 ! take next file
2805 !$OMP CRITICAL
2806 IF (ifile < nfilb) THEN
2807 ifile=ifile+1
2808 jrec=0
2809 readbufferinfo(1,ithr)=ifile
2810 readbufferinfo(3,ithr)=jrec
2811 END IF
2812 !$OMP END CRITICAL
2813 jfile=readbufferinfo(1,ithr)
2814
2815 END DO files
2816 !$OMP END PARALLEL
2817 ! compress pointers
2818 nrd=readbufferinfo(4,1) ! buffers from 1 .thread
2819 DO k=2,nthr
2820 iact =readbufferinfo(2,k)
2821 ioffp=iact*npointer
2822 nbuf=readbufferinfo(4,k)
2823 DO l=1,nbuf
2824 readbufferpointer(nrd+l)=readbufferpointer(ioffp+l)
2825 END DO
2826 nrd=nrd+nbuf
2827 END DO
2828
2829 more=0
2830 DO k=1,nthr
2831 jfile=readbufferinfo(1,k)
2832 IF (jfile > 0) THEN ! no eof yet
2833 readbufferinfo(2,k)=more
2834 more=more+1
2835 ELSE
2836 ! no more files, thread retires
2837 readbufferinfo(1,k)=0
2838 readbufferinfo(2,k)=-1
2839 readbufferinfo(3,k)=0
2841 readbufferinfo(6,k)=0
2842 END IF
2843 END DO
2844 ! record limit ?
2845 IF (mxrec > 0.AND.(ntot+nrd) >= mxrec) THEN
2846 nrd=mxrec-ntot
2847 more=-1
2848 DO k=1,nthr
2849 jfile=readbufferinfo(1,k)
2850 IF (jfile > 0) THEN ! rewind or close files
2851 nrc=readbufferinfo(3,k)
2852 IF (kfd(1,jfile) == 1) kfd(1,jfile)=-nrc
2853 kfile=kfd(2,jfile)
2854 IF (keepopen < 1) THEN ! close again
2855 CALL bincls(kfile,k)
2856 ELSE ! rewind
2857 CALL binrwd(kfile)
2858 END IF
2859 END IF
2860 END DO
2861 END IF
2862
2863 ntot=ntot+nrd
2864 nrec=ntot
2865 numreadbuffer=nrd
2866
2870
2871 DO WHILE (nloopn == 0.AND.ntot >= nrpr)
2872 WRITE(*,*) ' Record ',nrpr
2873 IF (nrpr < 100000) THEN
2874 nrpr=nrpr*10
2875 ELSE
2876 nrpr=nrpr+100000
2877 END IF
2878 END DO
2879
2880 IF (ncache > 0.AND.nloopn <= 1.AND. npri < mpri.AND.mprint > 1) THEN
2881 npri=npri+1
2882 IF (npri == 1) WRITE(*,100)
2883 WRITE(*,101) nrec, nrd, more ,ifile
2884100 FORMAT(/' PeRead records active file' &
2885 /' total block threads number')
2886101 FORMAT(' PeRead',4i10)
2887 END IF
2888
2889 IF (more <= 0) THEN
2890 ifile=0
2891 IF (floop) THEN
2892 ! check for file weights
2893 ds0=0.0_mpd
2894 ds1=0.0_mpd
2895 ds2=0.0_mpd
2896 maxrecordsize=0
2897 maxrecordfile=0
2898 DO k=1,nfilb
2899 IF (xfd(k) > maxrecordsize) THEN
2900 maxrecordsize=xfd(k)
2901 maxrecordfile=k
2902 END IF
2903 dw=real(-kfd(1,k),mpd)
2904 IF (wfd(k) /= 1.0) nfilw=nfilw+1
2905 ds0=ds0+dw
2906 ds1=ds1+dw*real(wfd(k),mpd)
2907 ds2=ds2+dw*real(wfd(k)**2,mpd)
2908 END DO
2909 print *, 'PEREAD: file ', maxrecordfile, 'with max record size ', maxrecordsize
2910 IF (nfilw > 0.AND.ds0 > 0.0_mpd) THEN
2911 ds1=ds1/ds0
2912 ds2=ds2/ds0-ds1*ds1
2913 DO lun=6,lunlog,2
2914 WRITE(lun,177) nfilw,real(ds1,mps),real(ds2,mps)
2915177 FORMAT(/' !!!!!',i4,' weighted binary files', &
2916 /' !!!!! mean, variance of weights =',2g12.4)
2917 END DO
2918 END IF
2919 ! integrate record numbers
2920 DO k=2,nfilb
2921 ifd(k)=ifd(k-1)-kfd(1,k-1)
2922 END DO
2923 ! sort
2924 IF (nthr > 1) CALL sort2k(kfd,nfilb)
2925 IF (skippedrecords > 0) THEN
2926 print *, 'PEREAD skipped records: ', skippedrecords
2927 ndimbuf=maxrecordsize/2 ! adjust buffer size
2928 END IF
2929 END IF
2930 lprint=.false.
2931 floop=.false.
2932 IF (ncache > 0.AND.nloopn <= 1.AND.mprint > 0) &
2934179 FORMAT(/' Read cache usage (#blocks, #records, ', &
2935 'min,max records/block'/17x,i10,i12,2i10)
2936 END IF
2937 RETURN
2938
2939END SUBROUTINE peread
2940
2948SUBROUTINE peprep(mode)
2949 USE mpmod
2950
2951 IMPLICIT NONE
2952
2953 INTEGER(mpi), INTENT(IN) :: mode
2954
2955 INTEGER(mpi) :: ibuf
2956 INTEGER(mpi) :: ichunk
2957 INTEGER(mpi) :: ist
2958 INTEGER(mpi) :: itgbi
2959 INTEGER(mpi) :: j
2960 INTEGER(mpi) :: ja
2961 INTEGER(mpi) :: jb
2962 INTEGER(mpi) :: jsp
2963 INTEGER(mpi) :: nst
2964 INTEGER(mpi), PARAMETER :: maxbad = 100 ! max number of bad records with print out
2965 INTEGER(mpi) :: nbad
2966 INTEGER(mpi) :: nerr
2967 INTEGER(mpi) :: inone
2968
2969 IF (mode > 0) THEN
2970#ifdef __PGIC__
2971 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
2972 ichunk=256
2973#else
2974 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
2975#endif
2976 ! parallelize record loop
2977 !$OMP PARALLEL DO &
2978 !$OMP DEFAULT(PRIVATE) &
2979 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,ICHUNK,iscerr,dscerr) &
2980 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
2981 DO ibuf=1,numreadbuffer ! buffer for current record
2982 ist=readbufferpointer(ibuf)+1
2984 DO ! loop over measurements
2985 CALL isjajb(nst,ist,ja,jb,jsp)
2986 IF(jb == 0) EXIT
2987 DO j=1,ist-jb
2988 readbufferdatai(jb+j)=inone( readbufferdatai(jb+j) ) ! translate to index
2989 END DO
2990 ! scale error ?
2991 IF (iscerr > 0) THEN
2992 IF (jb < ist) THEN
2993 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(1) ! 'global' measurement
2994 ELSE
2995 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(2) ! 'local' measurement
2996 END IF
2997 END IF
2998 END DO
2999 END DO
3000 !$OMP END PARALLEL DO
3001 END IF
3002
3003 !$POMP INST BEGIN(peprep)
3004#ifdef SCOREP_USER_ENABLE
3005 scorep_user_region_by_name_begin("UR_peprep", scorep_user_region_type_common)
3006#endif
3007 IF (mode <= 0) THEN
3008 nbad=0
3009 DO ibuf=1,numreadbuffer ! buffer for current record
3010 CALL pechk(ibuf,nerr)
3011 IF(nerr > 0) THEN
3012 nbad=nbad+1
3013 IF(nbad >= maxbad) EXIT
3014 ELSE
3015 ist=readbufferpointer(ibuf)+1
3017 DO ! loop over measurements
3018 CALL isjajb(nst,ist,ja,jb,jsp)
3019 IF(jb == 0) EXIT
3020 neqn=neqn+1
3021 IF(jb == ist) cycle
3022 negb=negb+1
3023 ndgb=ndgb+(ist-jb)
3024 DO j=1,ist-jb
3025 itgbi=inone( readbufferdatai(jb+j) ) ! generate index
3026 END DO
3027 END DO
3028 END IF
3029 END DO
3030 IF(nbad > 0) THEN
3031 CALL peend(20,'Aborted, bad binary records')
3032 stop 'PEREAD: stopping due to bad records'
3033 END IF
3034 END IF
3035#ifdef SCOREP_USER_ENABLE
3036 scorep_user_region_by_name_end("UR_peprep")
3037#endif
3038 !$POMP INST END(peprep)
3039
3040END SUBROUTINE peprep
3041
3049SUBROUTINE pechk(ibuf, nerr)
3050 USE mpmod
3051
3052 IMPLICIT NONE
3053 INTEGER(mpi) :: i
3054 INTEGER(mpi) :: is
3055 INTEGER(mpi) :: ist
3056 INTEGER(mpi) :: ioff
3057 INTEGER(mpi) :: ja
3058 INTEGER(mpi) :: jb
3059 INTEGER(mpi) :: jsp
3060 INTEGER(mpi) :: nan
3061 INTEGER(mpi) :: nst
3062
3063 INTEGER(mpi), INTENT(IN) :: ibuf
3064 INTEGER(mpi), INTENT(OUT) :: nerr
3065 SAVE
3066 ! ...
3067
3068 ist=readbufferpointer(ibuf)+1
3070 nerr=0
3071 is=ist
3072 jsp=0
3073 outer: DO WHILE(is < nst)
3074 ja=0
3075 jb=0
3076 inner1: DO
3077 is=is+1
3078 IF(is > nst) EXIT outer
3079 IF(readbufferdatai(is) == 0) EXIT inner1 ! found 1. marker
3080 END DO inner1
3081 ja=is
3082 inner2: DO
3083 is=is+1
3084 IF(is > nst) EXIT outer
3085 IF(readbufferdatai(is) == 0) EXIT inner2 ! found 2. marker
3086 END DO inner2
3087 jb=is
3088 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3089 ! special data
3090 jsp=jb ! pointer to special data
3091 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3092 cycle outer
3093 END IF
3094 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3095 is=is+1
3096 END DO
3097 END DO outer
3098 IF(is > nst) THEN
3099 ioff = readbufferpointer(ibuf)
3100 WRITE(*,100) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi)
3101100 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' is broken !!!')
3102 nerr=nerr+1
3103 ENDIF
3104 nan=0
3105 DO i=ist, nst
3106 IF(.NOT.(readbufferdatad(i) <= 0.0_mpr8).AND..NOT.(readbufferdatad(i) > 0.0_mpr8)) nan=nan+1
3107 END DO
3108 IF(nan > 0) THEN
3109 ioff = readbufferpointer(ibuf)
3110 WRITE(*,101) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi), nan
3111101 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' contains ', i6, ' NaNs !!!')
3112 nerr= nerr+2
3113 ENDIF
3114
3115END SUBROUTINE pechk
3116
3121SUBROUTINE pepgrp
3122 USE mpmod
3123 USE mpdalc
3124
3125 IMPLICIT NONE
3126
3127 INTEGER(mpi) :: ibuf
3128 INTEGER(mpi) :: ichunk
3129 INTEGER(mpi) :: iproc
3130 INTEGER(mpi) :: ioff
3131 INTEGER(mpi) :: ioffbi
3132 INTEGER(mpi) :: ist
3133 INTEGER(mpi) :: itgbi
3134 INTEGER(mpi) :: j
3135 INTEGER(mpi) :: ja
3136 INTEGER(mpi) :: jb
3137 INTEGER(mpi) :: jsp
3138 INTEGER(mpi) :: nalg
3139 INTEGER(mpi) :: neqna
3140 INTEGER(mpi) :: nnz
3141 INTEGER(mpi) :: nst
3142 INTEGER(mpi) :: nzero
3143 INTEGER(mpi) :: inone
3144 INTEGER(mpl) :: length
3145 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
3146
3147 CALL useone ! make (INONE) usable
3148 globalparheader(-2)=-1 ! set flag to inhibit further updates
3149 ! need back index
3150 IF (mcount > 0) THEN
3151 length=globalparheader(-1)*mthrd
3152 CALL mpalloc(backindexusage,length,'global variable-index array')
3154 END IF
3155 nzero=0
3156#ifdef __PGIC__
3157 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
3158 ichunk=256
3159#else
3160 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
3161#endif
3162 ! parallelize record loop
3163 !$OMP PARALLEL DO &
3164 !$OMP DEFAULT(PRIVATE) &
3165 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,backIndexUsage,globalParHeader,ICHUNK,MCOUNT) &
3166 !$OMP REDUCTION(+:NZERO) &
3167 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
3168 DO ibuf=1,numreadbuffer ! buffer for current record
3169 ist=readbufferpointer(ibuf)+1
3171 IF (mcount > 0) THEN
3172 ! count per record
3173 iproc=0
3174 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
3175 ioffbi=globalparheader(-1)*iproc
3176 nalg=0
3177 ioff=readbufferpointer(ibuf)
3178 DO ! loop over measurements
3179 CALL isjajb(nst,ist,ja,jb,jsp)
3180 IF(jb == 0) EXIT
3181 IF (ist > jb) THEN
3182 DO j=1,ist-jb
3183 IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
3184 nzero=nzero+1
3185 cycle ! skip 'zero global derivatives' for counting and grouping
3186 END IF
3187 itgbi=inone( readbufferdatai(jb+j) ) ! translate to index
3188 IF (backindexusage(ioffbi+itgbi) == 0) THEN
3189 nalg=nalg+1
3190 readbufferdatai(ioff+nalg)=itgbi
3191 backindexusage(ioffbi+itgbi)=nalg
3192 END IF
3193 END DO
3194 END IF
3195 END DO
3196 ! reset back index
3197 DO j=1,nalg
3198 itgbi=readbufferdatai(ioff+j)
3199 backindexusage(ioffbi+itgbi)=0
3200 END DO
3201 ! sort (record)
3202 CALL sort1k(readbufferdatai(ioff+1),nalg)
3203 readbufferdatai(ioff)=ioff+nalg
3204 ELSE
3205 ! count per equation
3206 nalg=1 ! reserve space for counter 'nnz'
3207 ioff=readbufferpointer(ibuf)
3208 neqna=0 ! number of accepted equations
3209 DO ! loop over measurements
3210 CALL isjajb(nst,ist,ja,jb,jsp)
3211 IF(jb == 0) EXIT
3212 IF (ist > jb) THEN
3213 nnz=0 ! number of non-zero derivatives
3214 DO j=1,ist-jb
3215 IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
3216 nzero=nzero+1
3217 cycle ! skip 'zero global derivatives' for counting and grouping
3218 END IF
3219 nnz=nnz+1
3220 readbufferdatai(ioff+nalg+nnz)=inone( readbufferdatai(jb+j) ) ! translate to index
3221 END DO
3222 IF (nnz == 0) cycle ! nothing for this equation
3223 readbufferdatai(ioff+nalg)=nnz
3224 ! sort (equation)
3225 CALL sort1k(readbufferdatai(ioff+nalg+1),nnz)
3226 nalg=nalg+nnz+1
3227 ! count (accepted) equations
3228 neqna=neqna+1
3229 END IF
3230 END DO
3231 readbufferdatai(ioff)=neqna
3232 END IF
3233 END DO
3234 !$OMP END PARALLEL DO
3235 nzgb=nzgb+nzero
3236
3237 !$POMP INST BEGIN(pepgrp)
3238#ifdef SCOREP_USER_ENABLE
3239 scorep_user_region_by_name_begin("UR_pepgrp", scorep_user_region_type_common)
3240#endif
3241 DO ibuf=1,numreadbuffer ! buffer for current record
3242 ist=readbufferpointer(ibuf)+1
3244 IF (mcount == 0) THEN
3245 ! equation level
3246 DO j=1,nst! loop over measurements
3247 nnz=readbufferdatai(ist)
3248 CALL pargrp(ist+1,ist+nnz)
3249 ist=ist+nnz+1
3250 END DO
3251 ELSE
3252 ! record level, group
3253 CALL pargrp(ist,nst)
3254 ENDIF
3255 END DO
3256 ! free back index
3257 IF (mcount > 0) THEN
3259 END IF
3260#ifdef SCOREP_USER_ENABLE
3261 scorep_user_region_by_name_end("UR_pepgrp")
3262#endif
3263 !$POMP INST END(pepgrp)
3264 globalparheader(-2)=0 ! reset flag to reenable further updates
3265
3266END SUBROUTINE pepgrp
3267
3275SUBROUTINE pargrp(inds,inde)
3276 USE mpmod
3277
3278 IMPLICIT NONE
3279
3280 INTEGER(mpi) :: istart
3281 INTEGER(mpi) :: itgbi
3282 INTEGER(mpi) :: j
3283 INTEGER(mpi) :: jstart
3284 INTEGER(mpi) :: jtgbi
3285 INTEGER(mpi) :: lstart
3286 INTEGER(mpi) :: ltgbi
3287
3288 INTEGER(mpi), INTENT(IN) :: inds
3289 INTEGER(mpi), INTENT(IN) :: inde
3290
3291 IF (inds > inde) RETURN
3292
3293 ltgbi=-1
3294 lstart=-1
3295 ! build up groups
3296 DO j=inds,inde
3297 itgbi=readbufferdatai(j)
3298 globalparlabelcounter(itgbi)=globalparlabelcounter(itgbi)+1 ! count entries
3299 istart=globalparlabelindex(3,itgbi) ! label of group start
3300 IF (istart == 0) THEN ! not yet in group
3301 IF (itgbi /= ltgbi+1) THEN ! start group
3303 ELSE
3304 IF (lstart == 0) THEN ! extend group
3306 ELSE ! start group
3307 globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)
3308 END IF
3309 END IF
3310 END IF
3311 ltgbi=itgbi
3312 lstart=istart
3313 END DO
3314 ! split groups:
3315 ! - start inside group?
3316 itgbi=readbufferdatai(inds)
3317 istart=globalparlabelindex(3,itgbi) ! label of group start
3318 jstart=globalparlabelindex(1,itgbi) ! label of first parameter
3319 IF (istart /= jstart) THEN ! start new group
3320 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3321 globalparlabelindex(3,itgbi) = jstart
3322 itgbi=itgbi+1
3323 IF (itgbi > globalparheader(-1)) EXIT
3324 END DO
3325 END IF
3326 ! - not neigbours anymore
3327 ltgbi=readbufferdatai(inds)
3328 DO j=inds+1,inde
3329 itgbi=readbufferdatai(j)
3330 IF (itgbi /= ltgbi+1) THEN
3331 ! split after ltgbi
3332 lstart=globalparlabelindex(3,ltgbi) ! label of last group start
3333 jtgbi=ltgbi+1 ! new group after ltgbi
3334 jstart=globalparlabelindex(1,jtgbi)
3335 DO WHILE (globalparlabelindex(3,jtgbi) == lstart)
3336 globalparlabelindex(3,jtgbi) = jstart
3337 jtgbi=jtgbi+1
3338 IF (jtgbi > globalparheader(-1)) EXIT
3339 IF (jtgbi == itgbi) jstart=globalparlabelindex(1,jtgbi)
3340 END DO
3341 ! split at itgbi
3342 jtgbi=itgbi
3343 istart=globalparlabelindex(3,jtgbi) ! label of group start
3344 jstart=globalparlabelindex(1,jtgbi) ! label of first parameter
3345 IF (istart /= jstart) THEN ! start new group
3346 DO WHILE (globalparlabelindex(3,jtgbi) == istart)
3347 globalparlabelindex(3,jtgbi) = jstart
3348 jtgbi=jtgbi+1
3349 IF (jtgbi > globalparheader(-1)) EXIT
3350 END DO
3351 END IF
3352 ENDIF
3353 ltgbi=itgbi
3354 END DO
3355 ! - end inside group?
3356 itgbi=readbufferdatai(inde)
3357 IF (itgbi < globalparheader(-1)) THEN
3358 istart=globalparlabelindex(3,itgbi) ! label of group start
3359 itgbi=itgbi+1
3360 jstart=globalparlabelindex(1,itgbi) ! label of new group start
3361 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3362 globalparlabelindex(3,itgbi) = jstart
3363 itgbi=itgbi+1
3364 IF (itgbi > globalparheader(-1)) EXIT
3365 END DO
3366 END IF
3367
3368END SUBROUTINE pargrp
3369
3392SUBROUTINE isjajb(nst,is,ja,jb,jsp)
3393 USE mpmod
3394
3395 IMPLICIT NONE
3396
3397 INTEGER(mpi), INTENT(IN) :: nst
3398 INTEGER(mpi), INTENT(IN OUT) :: is
3399 INTEGER(mpi), INTENT(OUT) :: ja
3400 INTEGER(mpi), INTENT(OUT) :: jb
3401 INTEGER(mpi), INTENT(OUT) :: jsp
3402 SAVE
3403 ! ...
3404
3405 jsp=0
3406 DO
3407 ja=0
3408 jb=0
3409 IF(is >= nst) RETURN
3410 DO
3411 is=is+1
3412 IF(readbufferdatai(is) == 0) EXIT
3413 END DO
3414 ja=is
3415 DO
3416 is=is+1
3417 IF(readbufferdatai(is) == 0) EXIT
3418 END DO
3419 jb=is
3420 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3421 ! special data
3422 jsp=jb ! pointer to special data
3423 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3424 cycle
3425 END IF
3426 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3427 is=is+1
3428 END DO
3429 EXIT
3430 END DO
3431
3432END SUBROUTINE isjajb
3433
3434
3435!***********************************************************************
3436! LOOPN ...
3442
3443SUBROUTINE loopn
3444 USE mpmod
3445
3446 IMPLICIT NONE
3447 REAL(mpd) :: dsum
3448 REAL(mps) :: elmt
3449 REAL(mpd) :: factrj
3450 REAL(mpd) :: factrk
3451 REAL(mps) :: peakd
3452 REAL(mps) :: peaki
3453 REAL(mps) :: ratae
3454 REAL(mpd) :: rhs
3455 REAL(mps) :: rloop
3456 REAL(mpd) :: sgm
3457 REAL(mps) :: used
3458 REAL(mps) :: usei
3459 REAL(mpd) :: weight
3460 INTEGER(mpi) :: i
3461 INTEGER(mpi) :: ia
3462 INTEGER(mpi) :: ib
3463 INTEGER(mpi) :: ioffb
3464 INTEGER(mpi) :: ipr
3465 INTEGER(mpi) :: itgbi
3466 INTEGER(mpi) :: itgbij
3467 INTEGER(mpi) :: itgbik
3468 INTEGER(mpi) :: ivgb
3469 INTEGER(mpi) :: ivgbij
3470 INTEGER(mpi) :: ivgbik
3471 INTEGER(mpi) :: j
3472 INTEGER(mpi) :: k
3473 INTEGER(mpi) :: lastit
3474 INTEGER(mpi) :: lun
3475 INTEGER(mpi) :: ncrit
3476 INTEGER(mpi) :: ngras
3477 INTEGER(mpi) :: nparl
3478 INTEGER(mpi) :: nr
3479 INTEGER(mpl) :: nrej
3480 INTEGER(mpi) :: inone
3481 INTEGER(mpi) :: ilow
3482 INTEGER(mpi) :: nlow
3483 INTEGER(mpi) :: nzero
3484 LOGICAL :: btest
3485
3486 REAL(mpd):: adder
3487 REAL(mpd)::funref
3488 REAL(mpd)::matij
3489
3490 SAVE
3491 ! ...
3492
3493 ! ----- book and reset ---------------------------------------------
3494 IF(nloopn == 0) THEN ! first call
3495 lastit=-1
3496 iitera=0
3497 END IF
3498
3499 nloopn=nloopn+1 ! increase loop counter
3500 funref=0.0_mpd
3501
3502 IF(nloopn == 1) THEN ! book histograms for 1. iteration
3503 CALL gmpdef(1,4,'Function value in iterations')
3504 IF (metsol == 4 .OR. metsol == 5) THEN ! extend to GMRES, i.e. 6?
3505 CALL gmpdef(2,3,'Number of MINRES steps vs iteration nr')
3506 END IF
3507 CALL hmpdef( 5,0.0,0.0,'Number of degrees of freedom')
3508 CALL hmpdef(11,0.0,0.0,'Number of local parameters')
3509 CALL hmpdef(16,0.0,24.0,'LOG10(cond(band part decomp.)) local fit ')
3510 CALL hmpdef(23,0.0,0.0, 'SQRT of diagonal elements without presigma')
3511 CALL hmpdef(24,0.0,0.0, 'Log10 of off-diagonal elements')
3512 CALL hmpdef(25,0.0,0.0, 'Relative individual pre-sigma')
3513 CALL hmpdef(26,0.0,0.0, 'Relative global pre-sigma')
3514 END IF
3515
3516
3517 CALL hmpdef(3,-prange,prange, & ! book
3518 'Normalized residuals of single (global) measurement')
3519 CALL hmpdef(12,-prange,prange, & ! book
3520 'Normalized residuals of single (local) measurement')
3521 CALL hmpdef(13,-prange,prange, & ! book
3522 'Pulls of single (global) measurement')
3523 CALL hmpdef(14,-prange,prange, & ! book
3524 'Pulls of single (local) measurement')
3525 CALL hmpdef(4,0.0,0.0,'Chi^2/Ndf after local fit')
3526 CALL gmpdef(4,5,'location, dispersion (res.) vs record nr')
3527 CALL gmpdef(5,5,'location, dispersion (pull) vs record nr')
3528
3529 ! WRITE(*,*) 'LOOPN ', NLOOPN, ' executing ICALCM=', ICALCM
3530
3531 ! reset
3532
3533 globalvector=0.0_mpd ! reset rhs vector IGVEC
3535 IF(icalcm == 1) THEN
3536 globalmatd=0.0_mpd
3537 globalmatf=0.
3538 IF (metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) matprecond=0.0_mpd
3539 END IF
3540
3541 IF(nloopn == 2) CALL hmpdef(6,0.0,0.0,'Down-weight fraction')
3542
3543 newite=.false.
3544 IF(iterat /= lastit) THEN ! new iteration
3545 newite=.true.
3546 funref=fvalue
3547 IF(nloopn > 1) THEN
3548 nrej=sum(nrejec)
3549 ! CALL MEND
3550 IF(iterat == 1) THEN
3552 ELSE IF(iterat >= 1) THEN
3553 chicut=sqrt(chicut)
3554 IF(chicut /= 0.0.AND.chicut < 1.5) chicut=1.0
3555 IF(chicut /= 0.0.AND.nrej == 0) chicut=1.0
3556 END IF
3557 END IF
3558 ! WRITE(*,111) ! header line
3559 END IF
3560
3561 nrejec=0 ! reset reject counter
3562 DO k=3,6
3563 writebufferheader(k)=0 ! cache usage
3564 writebufferheader(-k)=0
3565 END DO
3566 ! statistics per binary file
3567 DO i=1,nfilb
3568 jfd(i)=0
3569 cfd(i)=0.0
3570 dfd(i)=0
3571 END DO
3572
3573 IF (imonit /= 0) meashists=0 ! reset monitoring histograms
3574
3575 ! ----- read next data ----------------------------------------------
3576 DO
3577 CALL peread(nr) ! read records
3578 CALL peprep(1) ! prepare records
3580 IF (nr <= 0) EXIT ! next block of events ?
3581 END DO
3582 ! sum up RHS (over threads) once (reduction in LOOPBF: summation for each block)
3583 ioffb=0
3584 DO ipr=2,mthrd
3585 ioffb=ioffb+lenglobalvec
3586 DO k=1,lenglobalvec
3589 END DO
3590 END DO
3591
3592 IF (icalcm == 1) THEN
3593 ! PRINT *, ' cache/w ',(writeBufferHeader(-K),K=3,6),(writeBufferHeader(K),K=3,6)
3594 nparl=writebufferheader(3)
3595 ncrit=writebufferheader(4)
3596 used=real(writebufferheader(-5),mps)/real(writebufferheader(-3),mps)*0.1
3597 usei=real(writebufferheader(5),mps)/real(writebufferheader(3),mps)*0.1
3598 peakd=real(writebufferheader(-6),mps)*0.1
3599 peaki=real(writebufferheader(6),mps)*0.1
3600 WRITE(*,111) nparl,ncrit,usei,used,peaki,peakd
3601111 FORMAT(' Write cache usage (#flush,#overrun,<levels>,', &
3602 'peak(levels))'/2i7,',',4(f6.1,'%'))
3603 ! fill part of MINRES preconditioner matrix from binary files (formerly in mgupdt)
3604 IF (metsol >= 4.AND.metsol < 7) THEN
3605 IF (mbandw == 0) THEN
3606 ! default preconditioner (diagonal)
3607 DO i=1, nvgb
3608 matprecond(i)=matij(i,i)
3609 END DO
3610 ELSE IF (mbandw > 0) THEN
3611 ! band matrix
3612 DO i=1, nvgb
3613 ia=indprecond(i) ! index of diagonal element
3614 DO j=max(1,i-mbandw+1),i
3615 matprecond(ia-i+j)=matij(i,j)
3616 END DO
3617 END DO
3618 END IF
3619 END IF
3620 IF (ichkpg > 0) THEN
3621 ! check parameter groups
3622 CALL ckpgrp
3623 END IF
3624 END IF
3625
3626 ! check entries/counters
3627 nlow=0
3628 ilow=1
3629 nzero=0
3630 DO i=1,nvgb
3631 IF(globalcounter(i) == 0) nzero=nzero+1
3632 IF(globalcounter(i) < mreqena) THEN
3633 nlow=nlow+1
3634 IF(globalcounter(i) < globalcounter(ilow)) ilow=i
3635 END IF
3636 END DO
3637 IF(nlow > 0) THEN
3638 nalow=nalow+nlow
3639 IF(icalcm == 1) nxlow=max(nxlow,nlow) ! for matrix construction ?
3640 itgbi=globalparvartototal(ilow)
3641 print *
3642 print *, " ... warning ..."
3643 print *, " global parameters with too few (< MREQENA) accepted entries: ", nlow
3644 print *, " minimum entries: ", globalcounter(ilow), " for label ", globalparlabelindex(1,itgbi)
3645 print *
3646 END IF
3647 IF(icalcm == 1 .AND. nzero > 0) THEN
3648 ndefec = nzero ! rank defect
3649 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfgb, &
3650 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3651 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb, &
3652 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3653 IF (iforce == 0) THEN
3654 isubit=1
3655 WRITE(*,*) ' --> enforcing SUBITO mode'
3656 WRITE(lun,*) ' --> enforcing SUBITO mode'
3657 END IF
3658 END IF
3659
3660 ! ----- after end-of-data add contributions from pre-sigma ---------
3661
3662 IF(nloopn == 1) THEN
3663 ! plot diagonal elements
3664 elmt=0.0
3665 DO i=1,nvgb ! diagonal elements
3666 elmt=real(matij(i,i),mps)
3667 IF(elmt > 0.0) CALL hmpent(23,1.0/sqrt(elmt))
3668 END DO
3669 END IF
3670
3671
3672
3673 ! add pre-sigma contributions to matrix diagonal
3674
3675 ! WRITE(*,*) 'Adding to diagonal ICALCM IND6',ICALCM,IND6
3676
3677 IF(icalcm == 1) THEN
3678 DO ivgb=1,nvgb ! add evtl. pre-sigma
3679 ! WRITE(*,*) 'Index ',IVGB,IVGB,QM(IND6+IVGB)
3680 IF(globalparpreweight(ivgb) /= 0.0) THEN
3681 IF(ivgb > 0) CALL mupdat(ivgb,ivgb,globalparpreweight(ivgb))
3682 END IF
3683 END DO
3684 END IF
3685
3686 CALL hmpwrt(23)
3687 CALL hmpwrt(24)
3688 CALL hmpwrt(25)
3689 CALL hmpwrt(26)
3690
3691
3692 ! add regularization term to F and to rhs --------------------------
3693
3694 ! WRITE(*,*) 'NREGUL ',NREGUL,NLOOPN
3695
3696 IF(nregul /= 0) THEN ! add regularization term to F and to rhs
3697 DO ivgb=1,nvgb
3698 itgbi=globalparvartototal(ivgb) ! global parameter index
3700 adder=globalparpreweight(ivgb)*globalparameter(itgbi)**2
3701 CALL addsums(1, adder, 0, 1.0_mpl)
3702 END DO
3703 END IF
3704
3705
3706 ! ----- add contributions from "measurement" -----------------------
3707
3708
3709 i=1
3710 DO WHILE (i <= lenmeasurements)
3711 rhs=listmeasurements(i )%value ! right hand side
3712 sgm=listmeasurements(i+1)%value ! sigma parameter
3713 i=i+2
3714 weight=0.0
3715 IF(sgm > 0.0) weight=1.0/sgm**2
3716
3717 dsum=-rhs
3718
3719 ! loop over label/factor pairs
3720 ia=i
3721 DO
3722 i=i+1
3723 IF(i > lenmeasurements) EXIT
3724 IF(listmeasurements(i)%label < 0) EXIT
3725 END DO
3726 ib=i-1
3727
3728 DO j=ia,ib
3729 factrj=listmeasurements(j)%value
3730 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3731 IF(itgbij /= 0) THEN
3732 dsum=dsum+factrj*globalparameter(itgbij) ! update residuum
3733 END IF
3734 END DO
3735 DO j=ia,ib
3736 factrj=listmeasurements(j)%value
3737 IF (factrj == 0.0_mpd) cycle ! skip zero factors
3738 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3739 ! add to vector
3740 ivgbij=0
3741 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
3742 IF(ivgbij > 0) THEN
3743 globalvector(ivgbij)=globalvector(ivgbij) -weight*dsum*factrj ! vector
3744 globalcounter(ivgbij)=globalcounter(ivgbij)+1
3745 END IF
3746
3747 IF(icalcm == 1.AND.ivgbij > 0) THEN
3748 DO k=ia,j
3749 factrk=listmeasurements(k)%value
3750 itgbik=inone(listmeasurements(k)%label) ! total parameter index
3751 ! add to matrix
3752 ivgbik=0
3753 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
3754 IF(ivgbij > 0.AND.ivgbik > 0) THEN !
3755 CALL mupdat(ivgbij,ivgbik,weight*factrj*factrk)
3756 END IF
3757 END DO
3758 END IF
3759 END DO
3760
3761 adder=weight*dsum**2
3762 CALL addsums(1, adder, 1, 1.0_mpl)
3763
3764 END DO
3765
3766 ! ----- printout ---------------------------------------------------
3767
3768
3769 ! get accurate sum (Chi^2, (w)NDF)
3771
3772 flines=0.5_mpd*fvalue ! Likelihood function value
3773 rloop=iterat+0.01*nloopn
3774 actfun=real(funref-fvalue,mps)
3775 IF(nloopn == 1) actfun=0.0
3776 ngras=nint(angras,mpi)
3777 ratae=0.0 !!!
3778 IF(delfun /= 0.0) THEN
3779 ratae=min(99.9,actfun/delfun) !!!
3780 ratae=max(-99.9,ratae)
3781 END IF
3782
3783 ! rejects ...
3784
3785 nrej =sum(nrejec)
3786 IF(nloopn == 1) THEN
3787 IF(nrej /= 0) THEN
3788 WRITE(*,*) ' '
3789 WRITE(*,*) 'Data records rejected in initial loop:'
3790 CALL prtrej(6)
3791 END IF
3792 END IF
3793
3794 IF(newite.AND.iterat == 2) THEN
3795 IF(nrecpr /= 0.OR.nrecp2 /= 0) nrecer=nrec3
3796 IF(nrecpr < 0) THEN
3798 END IF
3799 IF(nrecp2 < 0) THEN
3801 END IF
3802 END IF
3803
3804 IF(nloopn <= 2) THEN
3805 IF(nhistp /= 0) THEN
3806 ! CALL HMPRNT(3) ! scaled residual of single measurement
3807 ! CALL HMPRNT(12) ! scaled residual of single measurement
3808 ! CALL HMPRNT(4) ! chi^2/Ndf
3809 END IF
3810 CALL hmpwrt(3)
3811 CALL hmpwrt(12)
3812 CALL hmpwrt(4)
3813 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
3814 IF (nloopn <= lfitnp) THEN
3815 CALL hmpwrt(13)
3816 CALL hmpwrt(14)
3817 CALL gmpwrt(5) ! location, dispersion (pull) as a function of record nr
3818 END IF
3819 END IF
3820 ! IF(NLOOPN.EQ.2.AND.NHISTP.NE.0) CALL HMPRNT(6)
3821 IF(nloopn == 2) CALL hmpwrt(6)
3822 IF(nloopn <= 1) THEN
3823 ! IF(NHISTP.NE.0) CALL HMPRNT(5) ! number of degrees of freedom
3824 ! IF(NHISTP.NE.0) CALL HMPRNT(11) ! Nlocal
3825 CALL hmpwrt(5)
3826 CALL hmpwrt(11)
3827 CALL hmpwrt(16)
3828 END IF
3829
3830 ! local fit: band matrix structure !?
3831 IF (nloopn == 1.AND.nbndr(1)+nbndr(2) > 0) THEN
3832 DO lun=6,8,2
3833 WRITE(lun,*) ' '
3834 WRITE(lun,*) ' === local fits have bordered band matrix structure ==='
3835 IF (nbndr(1) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(1),'number of records (upper/left border)'
3836 IF (nbndr(2) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(2),'number of records (lower/right border)'
3837 WRITE(lun,101) ' NBDRX',nbdrx,'max border size'
3838 WRITE(lun,101) ' NBNDX',nbndx,'max band width'
3839 END DO
3840 END IF
3841
3842 lastit=iterat
3843
3844 ! monitoring of residuals
3845 IF (imonit < 0 .OR. (nloopn == 1 .AND. btest(imonit,0))) CALL monres
3846
3847101 FORMAT(1x,a8,' =',i14,' = ',a)
3848! 101 FORMAT(' LOOPN',I6,' Function value',F22.8,10X,I6,' records')
3849! 102 FORMAT(' incl. constraint penalty',F22.8)
3850! 103 FORMAT(I13,3X,A,G12.4)
3851END SUBROUTINE loopn ! loop with fits
3852
3856
3857SUBROUTINE ploopa(lunp)
3858 USE mpmod
3859
3860 IMPLICIT NONE
3861
3862 INTEGER(mpi), INTENT(IN) :: lunp
3863 ! ..
3864 WRITE(lunp,*) ' '
3865 WRITE(lunp,101) ! header line
3866 WRITE(lunp,102) ! header line
3867101 FORMAT(' it fc',' fcn_value dfcn_exp slpr costh iit st', &
3868 ' ls step cutf',1x,'rejects hhmmss FMS')
3869102 FORMAT(' -- --',' ----------- -------- ---- ----- --- --', &
3870 ' -- ----- ----',1x,'------- ------ ---')
3871 RETURN
3872END SUBROUTINE ploopa ! title for iteration
3873
3877
3878SUBROUTINE ploopb(lunp)
3879 USE mpmod
3880
3881 IMPLICIT NONE
3882 INTEGER(mpi) :: ma
3883 INTEGER :: minut
3884 INTEGER(mpi) :: nfa
3885 INTEGER :: nhour
3886 INTEGER(mpl) :: nrej
3887 INTEGER(mpi) :: nsecnd
3888 REAL(mps) :: ratae
3889 REAL :: rstb
3890 REAL(mps) :: secnd
3891 REAL(mps) :: slopes(3)
3892 REAL(mps) :: steps(3)
3893 REAL, DIMENSION(2) :: ta
3894 REAl etime
3895
3896 INTEGER(mpi), INTENT(IN) :: lunp
3897
3898 CHARACTER (LEN=4):: ccalcm(4)
3899 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3900 SAVE
3901
3902 nrej=sum(nrejec) ! rejects
3903 IF(nrej > 9999999) nrej=9999999
3904 rstb=etime(ta)
3905 deltim=rstb-rstart
3906 CALL sechms(deltim,nhour,minut,secnd) ! time
3907 nsecnd=nint(secnd,mpi)
3908 IF(iterat == 0) THEN
3909 WRITE(lunp,103) iterat,nloopn,fvalue, &
3910 chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3911 ELSE
3912 IF (lsinfo == 10) THEN ! line search skipped
3913 WRITE(lunp,105) iterat,nloopn,fvalue,delfun, &
3914 iitera,istopa,chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3915 ELSE
3916 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3917 ratae=max(-99.9,min(99.9,slopes(2)/slopes(1)))
3918 stepl=steps(2)
3919 WRITE(lunp,104) iterat,nloopn,fvalue,delfun,ratae,angras, &
3920 iitera,istopa,lsinfo,stepl, chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3921 ENDIF
3922 END IF
3923103 FORMAT(i3,i3,e12.5,38x,f5.1, 1x,i7, i3,i2.2,i2.2,a4)
3924104 FORMAT(i3,i3,e12.5,1x,e8.2,f6.3,f6.3,i5,2i3,f6.3,f5.1, &
3925 1x,i7, i3,i2.2,i2.2,a4)
3926105 FORMAT(i3,i3,e12.5,1x,e8.2,12x,i5,i3,9x,f5.1, &
3927 1x,i7, i3,i2.2,i2.2,a4)
3928 RETURN
3929END SUBROUTINE ploopb ! iteration line
3930
3934
3935SUBROUTINE ploopc(lunp)
3936 USE mpmod
3937
3938 IMPLICIT NONE
3939 INTEGER(mpi) :: ma
3940 INTEGER(mpi) :: minut
3941 INTEGER(mpi) :: nfa
3942 INTEGER(mpi) :: nhour
3943 INTEGER(mpl) :: nrej
3944 INTEGER(mpi) :: nsecnd
3945 REAL(mps) :: ratae
3946 REAL :: rstb
3947 REAL(mps) :: secnd
3948 REAL(mps) :: slopes(3)
3949 REAL(mps) :: steps(3)
3950 REAL, DIMENSION(2) :: ta
3951 REAL etime
3952
3953 INTEGER(mpi), INTENT(IN) :: lunp
3954 CHARACTER (LEN=4):: ccalcm(4)
3955 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3956 SAVE
3957
3958 nrej=sum(nrejec) ! rejects
3959 IF(nrej > 9999999) nrej=9999999
3960 rstb=etime(ta)
3961 deltim=rstb-rstart
3962 CALL sechms(deltim,nhour,minut,secnd) ! time
3963 nsecnd=nint(secnd,mpi)
3964 IF (lsinfo == 10) THEN ! line search skipped
3965 WRITE(lunp,104) nloopn,fvalue,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3966 ELSE
3967 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3968 ratae=abs(slopes(2)/slopes(1))
3969 stepl=steps(2)
3970 WRITE(lunp,105) nloopn,fvalue, ratae,lsinfo, &
3971 stepl,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3972 END IF
3973104 FORMAT(3x,i3,e12.5,9x, 35x, i7, i3,i2.2,i2.2,a4)
3974105 FORMAT(3x,i3,e12.5,9x, f6.3,14x,i3,f6.3,6x, i7, i3,i2.2,i2.2,a4)
3975 RETURN
3976
3977END SUBROUTINE ploopc ! sub-iteration line
3978
3982
3983SUBROUTINE ploopd(lunp)
3984 USE mpmod
3985 IMPLICIT NONE
3986 INTEGER :: minut
3987 INTEGER :: nhour
3988 INTEGER(mpi) :: nsecnd
3989 REAL :: rstb
3990 REAL(mps) :: secnd
3991 REAL, DIMENSION(2) :: ta
3992 REAL etime
3993
3994 INTEGER(mpi), INTENT(IN) :: lunp
3995 CHARACTER (LEN=4):: ccalcm(4)
3996 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3997 SAVE
3998 rstb=etime(ta)
3999 deltim=rstb-rstart
4000 CALL sechms(deltim,nhour,minut,secnd) ! time
4001 nsecnd=nint(secnd,mpi)
4002
4003 WRITE(lunp,106) nhour,minut,nsecnd,ccalcm(lcalcm)
4004106 FORMAT(69x,i3,i2.2,i2.2,a4)
4005 RETURN
4006END SUBROUTINE ploopd
4007
4009SUBROUTINE explfc(lunit)
4010 USE mpdef
4011 USE mpmod, ONLY: metsol
4012
4013 IMPLICIT NONE
4014 INTEGER(mpi) :: lunit
4015 WRITE(lunit,*) ' '
4016 WRITE(lunit,102) 'Explanation of iteration table'
4017 WRITE(lunit,102) '=============================='
4018 WRITE(lunit,101) 'it', &
4019 'iteration number. Global parameters are improved for it > 0.'
4020 WRITE(lunit,102) 'First function evaluation is called iteraton 0.'
4021 WRITE(lunit,101) 'fc', 'number of function evaluations.'
4022 WRITE(lunit,101) 'fcn_value', 'value of 2 x Likelihood function (LF).'
4023 WRITE(lunit,102) 'The final value is the chi^2 value of the fit and should'
4024 WRITE(lunit,102) 'be about equal to the NDF (see below).'
4025 WRITE(lunit,101) 'dfcn_exp', &
4026 'expected reduction of the value of the Likelihood function (LF)'
4027 WRITE(lunit,101) 'slpr', 'ratio of the actual slope to inital slope.'
4028 WRITE(lunit,101) 'costh', &
4029 'cosine of angle between search direction and -gradient'
4030 IF (metsol == 4) THEN
4031 WRITE(lunit,101) 'iit', &
4032 'number of internal iterations in MINRES algorithm'
4033 WRITE(lunit,101) 'st', 'stop code of MINRES algorithm'
4034 WRITE(lunit,102) '< 0: rhs is very special, with beta2 = 0'
4035 WRITE(lunit,102) '= 0: rhs b = 0, i.e. the exact solution is x = 0'
4036 WRITE(lunit,102) '= 1 requested accuracy achieved, as determined by rtol'
4037 WRITE(lunit,102) '= 2 reasonable accuracy achieved, given eps'
4038 WRITE(lunit,102) '= 3 x has converged to an eigenvector'
4039 WRITE(lunit,102) '= 4 matrix ill-conditioned (Acond has exceeded 0.1/eps)'
4040 WRITE(lunit,102) '= 5 the iteration limit was reached'
4041 WRITE(lunit,102) '= 6 Matrix x vector does not define a symmetric matrix'
4042 WRITE(lunit,102) '= 7 Preconditioner does not define a symmetric matrix'
4043 ELSEIF (metsol == 5) THEN
4044 WRITE(lunit,101) 'iit', &
4045 'number of internal iterations in MINRES-QLP algorithm'
4046 WRITE(lunit,101) 'st', 'stop code of MINRES-QLP algorithm'
4047 WRITE(lunit,102) '= 1: beta_{k+1} < eps, iteration k is the final Lanczos step.'
4048 WRITE(lunit,102) '= 2: beta2 = 0. If M = I, b and x are eigenvectors of A.'
4049 WRITE(lunit,102) '= 3: beta1 = 0. The exact solution is x = 0.'
4050 WRITE(lunit,102) '= 4: A solution to (poss. singular) Ax = b found, given rtol.'
4051 WRITE(lunit,102) '= 5: A solution to (poss. singular) Ax = b found, given eps.'
4052 WRITE(lunit,102) '= 6: Pseudoinverse solution for singular LS problem, given rtol.'
4053 WRITE(lunit,102) '= 7: Pseudoinverse solution for singular LS problem, given eps.'
4054 WRITE(lunit,102) '= 8: The iteration limit was reached.'
4055 WRITE(lunit,102) '= 9: The operator defined by Aprod appears to be unsymmetric.'
4056 WRITE(lunit,102) '=10: The operator defined by Msolve appears to be unsymmetric.'
4057 WRITE(lunit,102) '=11: The operator defined by Msolve appears to be indefinite.'
4058 WRITE(lunit,102) '=12: xnorm has exceeded maxxnorm or will exceed it next iteration.'
4059 WRITE(lunit,102) '=13: Acond has exceeded Acondlim or 0.1/eps.'
4060 WRITE(lunit,102) '=14: Least-squares problem but no converged solution yet.'
4061 WRITE(lunit,102) '=15: A null vector obtained, given rtol.'
4062 ENDIF
4063 WRITE(lunit,101) 'ls', 'line search info'
4064 WRITE(lunit,102) '< 0 recalculate function'
4065 WRITE(lunit,102) '= 0: N or STP lt 0 or step not descending'
4066 WRITE(lunit,102) '= 1: Linesearch convergence conditions reached'
4067 WRITE(lunit,102) '= 2: interval of uncertainty at lower limit'
4068 WRITE(lunit,102) '= 3: max nr of line search calls reached'
4069 WRITE(lunit,102) '= 4: step at the lower bound'
4070 WRITE(lunit,102) '= 5: step at the upper bound'
4071 WRITE(lunit,102) '= 6: rounding error limitation'
4072 WRITE(lunit,101) 'step', &
4073 'the factor for the Newton step during the line search. Usually'
4074 WRITE(lunit,102) &
4075 'a value of 1 gives a sufficient reduction of the LF. Oherwise'
4076 WRITE(lunit,102) 'other step values are tried.'
4077 WRITE(lunit,101) 'cutf', &
4078 'cut factor. Local fits are rejected, if their chi^2 value'
4079 WRITE(lunit,102) &
4080 'is larger than the 3-sigma chi^2 value times the cut factor.'
4081 WRITE(lunit,102) 'A cut factor of 1 is used finally, but initially a larger'
4082 WRITE(lunit,102) 'factor may be used. A value of 0.0 means no cut.'
4083 WRITE(lunit,101) 'rejects', 'total number of rejected local fits.'
4084 WRITE(lunit,101) 'hmmsec', 'the time in hours (h), minutes (mm) and seconds.'
4085 WRITE(lunit,101) 'FMS', 'calculation of Function value, Matrix, Solution.'
4086 WRITE(lunit,*) ' '
4087
4088101 FORMAT(a9,' = ',a)
4089102 FORMAT(13x,a)
4090END SUBROUTINE explfc
4091
4099
4100SUBROUTINE mupdat(i,j,add) !
4101 USE mpmod
4102
4103 IMPLICIT NONE
4104
4105 INTEGER(mpi), INTENT(IN) :: i
4106 INTEGER(mpi), INTENT(IN) :: j
4107 REAL(mpd), INTENT(IN) :: add
4108
4109 INTEGER(mpl):: ijadd
4110 INTEGER(mpl):: ijcsr3
4111 INTEGER(mpl):: ia
4112 INTEGER(mpl):: ja
4113 INTEGER(mpl):: ij
4114 ! ...
4115 IF(i <= 0.OR.j <= 0.OR. add == 0.0_mpd) RETURN
4116 ia=max(i,j) ! larger
4117 ja=min(i,j) ! smaller
4118 ij=0
4119 IF(matsto == 3) THEN
4120 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
4121 ij=ijcsr3(i,j) ! inline code requires same time
4122 IF (ij > 0) globalmatd(ij)=globalmatd(ij)+add
4123 RETURN
4124 ELSE ! sparse symmetric matrix (BSR3)
4125 ! block index
4126 ij=ijcsr3((i-1)/matbsz+1,(j-1)/matbsz+1)
4127 IF (ij > 0) THEN
4128 ! index of first element in block
4129 ij=(ij-1)*matbsz*matbsz+1
4130 ! adjust index for position in block
4131 ij=ij+mod(int(ia-1,mpi),matbsz)*matbsz+mod(int(ja-1,mpi),matbsz)
4132 globalmatd(ij)=globalmatd(ij)+add
4133 ENDIF
4134 RETURN
4135 END IF
4136 ELSE IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4137 ij=ijadd(i,j) ! inline code requires same time
4138 IF (ij == 0) RETURN ! pair is suppressed
4139 IF (ij > 0) THEN
4140 globalmatd(ij)=globalmatd(ij)+add
4141 ELSE
4142 globalmatf(-ij)=globalmatf(-ij)+real(add,mps)
4143 END IF
4144 ELSE ! full or unpacked (block diagonal) symmetric matrix
4145 ! global (ia,ib) to local (row,col) in block
4146 ij=globalrowoffsets(ia)+ja
4147 globalmatd(ij)=globalmatd(ij)+add
4148 END IF
4149 ! MINRES preconditioner
4150 IF(metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) THEN
4151 ij=0 ! no update
4152 IF(ia <= nvgb) THEN ! variable global parameter
4153 IF(mbandw > 0) THEN ! band matrix for Cholesky decomposition
4154 ij=indprecond(ia)-ia+ja
4155 IF(ia > 1.AND.ij <= indprecond(ia-1)) ij=0
4156 ELSE ! default preconditioner (diagonal)
4157 IF(ja == ia) ij=ia
4158 END IF
4159 ELSE ! Lagrange multiplier
4160 ij=offprecond(ia-nvgb)+ja
4161 END IF
4162 ! bad index?
4163 IF(ij < 0.OR.ij > size(matprecond)) THEN
4164 CALL peend(23,'Aborted, bad matrix index')
4165 stop 'mupdat: bad index'
4166 END IF
4167 ! update?
4168 IF(ij /= 0) matprecond(ij)=matprecond(ij)+add
4169 END IF
4170END SUBROUTINE mupdat
4171
4172
4184
4185SUBROUTINE mgupdt(i,j1,j2,il,jl,n,sub)
4186 USE mpmod
4187
4188 IMPLICIT NONE
4189
4190 INTEGER(mpi), INTENT(IN) :: i
4191 INTEGER(mpi), INTENT(IN) :: j1
4192 INTEGER(mpi), INTENT(IN) :: j2
4193 INTEGER(mpi), INTENT(IN) :: il
4194 INTEGER(mpi), INTENT(IN) :: jl
4195 INTEGER(mpi), INTENT(IN) :: n
4196 REAL(mpd), INTENT(IN) :: sub((n*n+n)/2)
4197
4198 INTEGER(mpl):: ij
4199 INTEGER(mpl):: ioff
4200 INTEGER(mpi):: ia
4201 INTEGER(mpi):: ia1
4202 INTEGER(mpi):: ib
4203 INTEGER(mpi):: iblast
4204 INTEGER(mpi):: iblock
4205 INTEGER(mpi):: ijl
4206 INTEGER(mpi):: iprc
4207 INTEGER(mpi):: ir
4208 INTEGER(mpi):: ja
4209 INTEGER(mpi):: jb
4210 INTEGER(mpi):: jblast
4211 INTEGER(mpi):: jblock
4212 INTEGER(mpi):: jc
4213 INTEGER(mpi):: jc1
4214 INTEGER(mpi):: jpg
4215 INTEGER(mpi):: k
4216 INTEGER(mpi):: lr
4217 INTEGER(mpi):: nc
4218
4219 INTEGER(mpl) ijcsr3
4220 ! ...
4221 IF(i <= 0.OR.j1 <= 0.OR.j2 > i) RETURN
4222
4223 IF(matsto == 3) THEN ! sparse symmetric matrix (CSR3, upper triangle)
4224 ja=globalallindexgroups(i) ! first (global) column
4225 jb=globalallindexgroups(i+1)-1 ! last (global) column
4226 ia1=globalallindexgroups(j1) ! first (global) row
4227 ! loop over groups (now in same column)
4228 DO jpg=j1,j2
4229 ia=globalallindexgroups(jpg) ! first (global) row in group
4230 ib=globalallindexgroups(jpg+1)-1 ! last (global) row in group
4231 IF (matbsz < 2) THEN
4232 ! CSR3
4233 ij=ijcsr3(ia,ja)
4234 IF (ij == 0) THEN
4235 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc, matsto
4236 stop
4237 END IF
4238 ioff=ij-ja ! offset
4239 DO ir=ia,ib
4240 jc1=max(ir,ja)
4241 k=il+jc1-ja
4242 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4243 DO jc=jc1,jb
4244 globalmatd(ioff+jc)=globalmatd(ioff+jc)-sub(ijl)
4245 ijl=ijl+k
4246 k=k+1
4247 END DO
4248 ioff=ioff+csr3rowoffsets(ir+1)-csr3rowoffsets(ir)-1
4249 END DO
4250 ELSE
4251 ! BSR3
4252 iblast=-1
4253 jblast=-1
4254 ioff=0
4255 DO ir=ia,ib
4256 iblock=(ir-1)/matbsz+1
4257 jc1=max(ir,ja)
4258 k=il+jc1-ja
4259 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4260 DO jc=jc1,jb
4261 jblock=(jc-1)/matbsz+1
4262 ! index of first element in (new) block
4263 IF (jblock /= jblast.OR.iblock /= iblast) THEN
4264 ioff=(ijcsr3(iblock,jblock)-1)*matbsz*matbsz+1
4265 iblast=iblock
4266 jblast=jblock
4267 END IF
4268 ! adjust index for position in block
4269 ij=ioff+mod(int(ir-1,mpi),matbsz)+mod(int(jc-1,mpi),matbsz)*matbsz
4270 globalmatd(ij)=globalmatd(ij)-sub(ijl)
4271 ijl=ijl+k
4272 k=k+1
4273 END DO
4274 END DO
4275 END IF
4276 END DO
4277 RETURN
4278 END IF
4279
4280 ! lower triangle
4281 ia=globalallindexgroups(i) ! first (global) row
4282 ib=globalallindexgroups(i+1)-1 ! last (global) row
4283 ja=globalallindexgroups(j1) ! first (global) column
4284 jb=globalallindexgroups(j2+1)-1 ! last (global) column
4285
4286 IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4287 CALL ijpgrp(i,j1,ij,lr,iprc) ! index of first element of group 'j1'
4288 IF (ij == 0) THEN
4289 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc,matsto
4290 stop
4291 END IF
4292 k=il
4293 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4294 DO ir=ia,ib
4295 nc=min(ir,jb)-ja ! number of columns -1
4296 IF (jb >= ir) THEN ! diagonal element
4297 globalmatd(ir)=globalmatd(ir)-sub(ijl+jl+nc)
4298 nc=nc-1
4299 END IF
4300 ! off-diagonal elements
4301 IF (iprc == 1) THEN
4302 globalmatd(ij:ij+nc)=globalmatd(ij:ij+nc)-sub(ijl+jl:ijl+jl+nc)
4303 ELSE
4304 globalmatf(ij:ij+nc)=globalmatf(ij:ij+nc)-real(sub(ijl+jl:ijl+jl+nc),mps)
4305 END IF
4306 ij=ij+lr
4307 ijl=ijl+k
4308 k=k+1
4309 END DO
4310 ELSE ! full or unpacked (block diagonal) symmetric matrix
4311 k=il
4312 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4313 DO ir=ia,ib
4314 ! global (ir,0) to local (row,col) in block
4315 ij=globalrowoffsets(ir)
4316 nc=min(ir,jb)-ja ! number of columns -1
4317 globalmatd(ij+ja:ij+ja+nc)=globalmatd(ij+ja:ij+ja+nc)-sub(ijl+jl:ijl+jl+nc)
4318 ijl=ijl+k
4319 k=k+1
4320 END DO
4321 END IF
4322
4323END SUBROUTINE mgupdt
4324
4325
4352
4353SUBROUTINE loopbf(nrej,numfil,naccf,chi2f,ndff)
4354 USE mpmod
4355
4356 IMPLICIT NONE
4357 REAL(mpd) :: cauchy
4358 REAL(mps) :: chichi
4359 REAL(mps) :: chlimt
4360 REAL(mps) :: chndf
4361 REAL(mpd) :: chuber
4362 REAL(mpd) :: down
4363 REAL(mpd) :: pull
4364 REAL(mpd) :: r1
4365 REAL(mpd) :: r2
4366 REAL(mps) :: rec
4367 REAL(mpd) :: rerr
4368 REAL(mpd) :: resid
4369 REAL(mps) :: resing
4370 REAL(mpd) :: resmax
4371 REAL(mpd) :: rmeas
4372 REAL(mpd) :: rmloc
4373 REAL(mpd) :: suwt
4374 REAL(mps) :: used
4375 REAL(mpd) :: wght
4376 REAL(mps) :: chindl
4377 INTEGER(mpi) :: i
4378 INTEGER(mpi) :: ia
4379 INTEGER(mpi) :: ib
4380 INTEGER(mpi) :: ibuf
4381 INTEGER(mpi) :: ichunk
4382 INTEGER(mpl) :: icmn
4383 INTEGER(mpl) :: icost
4384 INTEGER(mpi) :: id
4385 INTEGER(mpi) :: idiag
4386 INTEGER(mpi) :: ieq
4387 INTEGER(mpi) :: iext
4388 INTEGER(mpi) :: ij
4389 INTEGER(mpi) :: ije
4390 INTEGER(mpi) :: ijn
4391 INTEGER(mpi) :: ik
4392 INTEGER(mpi) :: ike
4393 INTEGER(mpi) :: il
4394 INTEGER(mpi) :: im
4395 INTEGER(mpi) :: imeas
4396 INTEGER(mpi) :: in
4397 INTEGER(mpi) :: inv
4398 INTEGER(mpi) :: ioffb
4399 INTEGER(mpi) :: ioffc
4400 INTEGER(mpi) :: ioffd
4401 INTEGER(mpi) :: ioffe
4402 INTEGER(mpi) :: ioffi
4403 INTEGER(mpi) :: ioffq
4404 INTEGER(mpi) :: iprc
4405 INTEGER(mpi) :: iprcnx
4406 INTEGER(mpi) :: iprdbg
4407 INTEGER(mpi) :: iproc
4408 INTEGER(mpi) :: irbin
4409 INTEGER(mpi) :: isize
4410 INTEGER(mpi) :: ist
4411 INTEGER(mpi) :: iter
4412 INTEGER(mpi) :: itgbi
4413 INTEGER(mpi) :: ivgbj
4414 INTEGER(mpi) :: ivgbk
4415 INTEGER(mpi) :: ivpgrp
4416 INTEGER(mpi) :: j
4417 INTEGER(mpi) :: j1
4418 INTEGER(mpi) :: ja
4419 INTEGER(mpi) :: jb
4420 INTEGER(mpi) :: jk
4421 INTEGER(mpi) :: jl
4422 INTEGER(mpi) :: jl1
4423 INTEGER(mpi) :: jn
4424 INTEGER(mpi) :: jnx
4425 INTEGER(mpi) :: joffd
4426 INTEGER(mpi) :: joffi
4427 INTEGER(mpi) :: jproc
4428 INTEGER(mpi) :: jrc
4429 INTEGER(mpi) :: jsp
4430 INTEGER(mpi) :: k
4431 INTEGER(mpi) :: kbdr
4432 INTEGER(mpi) :: kbdrx
4433 INTEGER(mpi) :: kbnd
4434 INTEGER(mpi) :: kfl
4435 INTEGER(mpi) :: kx
4436 INTEGER(mpi) :: lvpgrp
4437 INTEGER(mpi) :: mbdr
4438 INTEGER(mpi) :: mbnd
4439 INTEGER(mpi) :: mside
4440 INTEGER(mpi) :: nalc
4441 INTEGER(mpi) :: nalg
4442 INTEGER(mpi) :: nan
4443 INTEGER(mpi) :: nb
4444 INTEGER(mpi) :: ndf
4445 INTEGER(mpi) :: ndown
4446 INTEGER(mpi) :: neq
4447 INTEGER(mpi) :: nfred
4448 INTEGER(mpi) :: nfrei
4449 INTEGER(mpi) :: ngg
4450 INTEGER(mpi) :: nprdbg
4451 INTEGER(mpi) :: nrank
4452 INTEGER(mpl) :: nrc
4453 INTEGER(mpi) :: nst
4454 INTEGER(mpi) :: nter
4455 INTEGER(mpi) :: nweig
4456 INTEGER(mpi) :: ngrp
4457 INTEGER(mpi) :: npar
4458
4459 INTEGER(mpl), INTENT(IN OUT) :: nrej(6)
4460 INTEGER(mpi), INTENT(IN) :: numfil
4461 INTEGER(mpi), INTENT(IN OUT) :: naccf(numfil)
4462 REAL(mps), INTENT(IN OUT) :: chi2f(numfil)
4463 INTEGER(mpi), INTENT(IN OUT) :: ndff(numfil)
4464
4465 REAL(mps) :: cndl10
4466 REAL(mpd) :: dchi2
4467 REAL(mpd) :: dvar
4468 REAL(mpd) :: dw1
4469 REAL(mpd) :: dw2
4470 REAL(mpd) :: evdmin
4471 REAL(mpd) :: evdmax
4472 REAL(mpd) :: summ
4473 INTEGER(mpi) :: ijprec
4474
4475 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
4476
4477 LOGICAL:: lprnt
4478 LOGICAL::lhist
4479
4480 CHARACTER (LEN=3):: chast
4481 DATA chuber/1.345_mpd/ ! constant for Huber down-weighting
4482 DATA cauchy/2.3849_mpd/ ! constant for Cauchy down-weighting
4483 SAVE chuber,cauchy
4484 ! ...
4485
4486 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
4487 ! reset header, 3 words per thread:
4488 ! number of entries, offset to data, indices
4491 nprdbg=0
4492 iprdbg=-1
4493
4494 ! parallelize record loop
4495 ! private copy of NREJ,.. for each thread, combined at end, init with 0.
4496 !$OMP PARALLEL DO &
4497 !$OMP DEFAULT(PRIVATE) &
4498 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI, &
4499 !$OMP readBufferDataD,writeBufferHeader,writeBufferInfo, &
4500 !$OMP writeBufferData,writeBufferIndices,writeBufferUpdates,globalVector,globalCounter, &
4501 !$OMP globalParameter,globalParLabelIndex,globalIndexUsage,backIndexUsage, &
4502 !$OMP measBins,numMeas,measIndex,measRes,measHists,globalAllParToGroup,globalAllIndexGroups, &
4503 !$OMP localCorrections,localEquations,ifd, &
4504 !$OMP NAGB,NVGB,NAGBN,ICALCM,ICHUNK,NLOOPN,NRECER,NPRDBG,IPRDBG, &
4505 !$OMP NEWITE,CHICUT,LHUBER,CHUBER,ITERAT,NRECPR,MTHRD,NSPC,NAEQN, &
4506 !$OMP DWCUT,CHHUGE,NRECP2,CAUCHY,LFITNP,LFITBB,IMONIT,IMONMD,MONPG1,LUNLOG,MDEBUG,CNDLMX) &
4507 !$OMP REDUCTION(+:NREJ,NBNDR,NACCF,CHI2F,NDFF) &
4508 !$OMP REDUCTION(MAX:NBNDX,NBDRX) &
4509 !$OMP REDUCTION(MIN:NREC3) &
4510 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
4511 DO ibuf=1,numreadbuffer ! buffer for current record
4512 jrc=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
4513 kfl=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
4514 nrc=ifd(kfl)+jrc ! global record number
4515 dw1=real(readbufferdatad(readbufferpointer(ibuf)-1),mpd) ! weight
4516 dw2=sqrt(dw1)
4517
4518 iproc=0
4519 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
4520 ioffb=nagb*iproc ! offset 'f'.
4521 ioffc=nagbn*iproc ! offset 'c'.
4522 ioffe=nvgb*iproc ! offset 'e'
4523 ioffd=writebufferheader(-1)*iproc+writebufferinfo(2,iproc+1) ! offset data
4524 ioffi=writebufferheader(1)*iproc+writebufferinfo(3,iproc+1)+3 ! offset indices
4525 ioffq=naeqn*iproc ! offset equations (measurements)
4526 ! ----- reset ------------------------------------------------------
4527 lprnt=.false.
4528 lhist=(iproc == 0)
4529 rec=real(nrc,mps) ! floating point value
4530 IF(nloopn == 1.AND.mod(nrc,100000_mpl) == 0) THEN
4531 WRITE(*,*) 'Record',nrc,' ... still reading'
4532 IF(monpg1>0) WRITE(lunlog,*) 'Record',nrc,' ... still reading'
4533 END IF
4534
4535 ! printout/debug only for one thread at a time
4536
4537
4538 ! flag for record printout -----------------------------------------
4539
4540 lprnt=.false.
4541 IF(newite.AND.(iterat == 1.OR.iterat == 3)) THEN
4542 IF(nrc == nrecpr) lprnt=.true.
4543 IF(nrc == nrecp2) lprnt=.true.
4544 IF(nrc == nrecer) lprnt=.true.
4545 END IF
4546 IF (lprnt)THEN
4547 !$OMP ATOMIC
4548 nprdbg=nprdbg+1 ! number of threads with debug
4549 IF (nprdbg == 1) iprdbg=iproc ! first thread with debug
4550 IF (iproc /= iprdbg) lprnt=.false.
4551 ! print *, ' LPRNT ', NRC, NPRDBG, IPRDBG, IPROC, LPRNT
4552 END IF
4553 IF(lprnt) THEN
4554 WRITE(1,*) ' '
4555 WRITE(1,*) '------------------ Loop',nloopn, &
4556 ': Printout for record',nrc,iproc
4557 WRITE(1,*) ' '
4558 END IF
4559
4560 ! ----- print data -------------------------------------------------
4561
4562 IF(lprnt) THEN
4563 imeas=0 ! local derivatives
4564 ist=readbufferpointer(ibuf)+1
4566 DO ! loop over measurements
4567 CALL isjajb(nst,ist,ja,jb,jsp)
4568 IF(ja == 0) EXIT
4569 IF(imeas == 0) WRITE(1,1121)
4570 imeas=imeas+1
4571 WRITE(1,1122) imeas,readbufferdatad(ja),readbufferdatad(jb), &
4572 (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
4573 END DO
45741121 FORMAT(/'Measured value and local derivatives'/ &
4575 ' i measured std_dev index...derivative ...')
45761122 FORMAT(i3,2g12.4,3(i3,g12.4)/(27x,3(i3,g12.4)))
4577
4578 imeas=0 ! global derivatives
4579 ist=readbufferpointer(ibuf)+1
4581 DO ! loop over measurements
4582 CALL isjajb(nst,ist,ja,jb,jsp)
4583 IF(ja == 0) EXIT
4584 IF(imeas == 0) WRITE(1,1123)
4585 imeas=imeas+1
4586 IF (jb < ist) THEN
4587 IF(ist-jb > 2) THEN
4588 WRITE(1,1124) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4589 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4590 ELSE
4591 WRITE(1,1125) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4592 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4593 END IF
4594 END IF
4595 END DO
45961123 FORMAT(/'Global derivatives'/ &
4597 ' i label gindex vindex derivative ...')
45981124 FORMAT(i3,2(i9,i7,i7,g12.4)/(3x,2(i9,i7,i7,g12.4)))
45991125 FORMAT(i3,2(i9,i7,i7,g12.4))
4600 END IF
4601
4602 ! ----- first loop -------------------------------------------------
4603 ! ------ prepare local fit ------
4604 ! count local and global derivates
4605 ! subtract actual alignment parameters from the measured data
4606
4607 IF(lprnt) THEN
4608 WRITE(1,*) ' '
4609 WRITE(1,*) 'Data corrections using values of global parameters'
4610 WRITE(1,*) '=================================================='
4611 WRITE(1,101)
4612 END IF
4613 nalg=0 ! count number of global derivatives
4614 nalc=0 ! count number of local derivatives
4615 neq=0 ! count number of equations
4616
4617 ist=readbufferpointer(ibuf)+1
4619 DO ! loop over measurements
4620 CALL isjajb(nst,ist,ja,jb,jsp)
4621 IF(ja == 0) EXIT
4622 rmeas=real(readbufferdatad(ja),mpd) ! data
4623 neq=neq+1 ! count equation
4624 localequations(1,ioffq+neq)=ja
4625 localequations(2,ioffq+neq)=jb
4626 localequations(3,ioffq+neq)=ist
4627 ! subtract global ... from measured value
4628 DO j=1,ist-jb ! global parameter loop
4629 itgbi=readbufferdatai(jb+j) ! global parameter label
4630 rmeas=rmeas-real(readbufferdatad(jb+j),mpd)*globalparameter(itgbi) ! subtract !!! reversed
4631 IF (icalcm == 1) THEN
4632 ij=globalparlabelindex(2,itgbi) ! -> index of variable global parameter
4633 IF(ij > 0) THEN
4634 ijn=backindexusage(ioffe+ij) ! get index of index
4635 IF(ijn == 0) THEN ! not yet included
4636 nalg=nalg+1 ! count
4637 globalindexusage(ioffc+nalg)=ij ! store global index
4638 backindexusage(ioffe+ij)=nalg ! store back index
4639 END IF
4640 END IF
4641 END IF
4642 END DO
4643 IF(lprnt) THEN
4644 IF (jb < ist) WRITE(1,102) neq,readbufferdatad(ja),rmeas,readbufferdatad(jb)
4645 END IF
4646 readbufferdatad(ja)=real(rmeas,mpr8) ! global contribution subtracted
4647 DO j=1,jb-ja-1 ! local parameter loop
4648 ij=readbufferdatai(ja+j)
4649 nalc=max(nalc,ij) ! number of local parameters
4650 END DO
4651 END DO
4652101 FORMAT(' index measvalue corrvalue sigma')
4653102 FORMAT(i6,2x,2g12.4,' +-',g12.4)
4654
4655 IF(nalc <= 0) GO TO 90
4656
4657 ngg=(nalg*nalg+nalg)/2
4658 ngrp=0
4659 IF (icalcm == 1) THEN
4660 localglobalmatrix(:nalg*nalc)=0.0_mpd ! reset global-local matrix
4661 localglobalmap(:nalg*nalc)=0 ! reset global-local map
4662 ! store parameter group indices
4663 CALL sort1k(globalindexusage(ioffc+1),nalg) ! sort global par.
4664 lvpgrp=-1
4665 npar=0
4666 DO k=1,nalg
4667 iext=globalindexusage(ioffc+k)
4668 backindexusage(ioffe+iext)=k ! update back index
4669 ivpgrp=globalallpartogroup(iext) ! group
4670 IF (ivpgrp /= lvpgrp) THEN
4671 ngrp=ngrp+1
4672 writebufferindices(ioffi+ngrp)=ivpgrp ! global par group indices
4673 lvpgrp=ivpgrp
4674 npar=npar+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4675 END IF
4676 END DO
4677 ! check NPAR==NALG
4678 IF (npar /= nalg) THEN
4679 print *, ' mismatch of number of global parameters ', nrc, nalg, npar, ngrp
4680 print *, globalindexusage(ioffc+1:ioffc+nalg)
4681 print *, writebufferindices(ioffi+1:ioffi+ngrp)
4682 j=0
4683 DO k=1,ngrp
4684 ivpgrp=writebufferindices(ioffi+k)
4685 j=j+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4686 IF (globalallpartogroup(globalindexusage(ioffc+j)) /= ivpgrp) &
4687 print *, ' bad group ', k, j, ivpgrp, globalindexusage(ioffc+j)
4688 END DO
4689 CALL peend(35,'Aborted, mismatch of number of global parameters')
4690 stop ' mismatch of number of global parameters '
4691 ENDIF
4692 ! index header
4693 writebufferindices(ioffi-2)=jrc ! record number in file
4694 writebufferindices(ioffi-1)=nalg ! number of global parameters
4695 writebufferindices(ioffi )=ngrp ! number of global par groups
4696 DO k=1,ngg
4697 writebufferupdates(ioffd+k)=0.0_mpd ! reset global-global matrix
4698 END DO
4699 END IF
4700 ! ----- iteration start and check ---------------------------------
4701
4702 nter=1 ! first loop without down-weighting
4703 IF(nloopn /= 1.AND.lhuber /= 0) nter=lhuber
4704 localcorrections(ioffq+1:ioffq+neq) = 0._mpd
4705
4706 ! check matrix for bordered band structure (MBDR+MBND+1 <= NALC)
4707 mbnd=-1
4708 mbdr=nalc
4709 mside=-1 ! side (1: upper/left border, 2: lower/right border)
4710 DO i=1, 2*nalc
4711 ibandh(i)=0
4712 END DO
4713 idiag=1
4714
4715 iter=0
4716 resmax=0.0
4717 DO WHILE(iter < nter) ! outlier suppresssion iteration loop
4718 iter=iter+1
4719 resmax=0.0
4720 IF(lprnt) THEN
4721 WRITE(1,*) ' '
4722 WRITE(1,*) 'Outlier-suppression iteration',iter,' of',nter
4723 WRITE(1,*) '=========================================='
4724 WRITE(1,*) ' '
4725 imeas=0
4726 END IF
4727
4728 ! ----- second loop ------------------------------------------------
4729 ! accumulate normal equations for local fit and determine solution
4730 DO i=1,nalc
4731 blvec(i)=0.0_mpd ! reset vector
4732 END DO
4733 DO i=1,(nalc*nalc+nalc)/2 ! GF: FIXME - not really, local parameter number...
4734 clmat(i)=0.0_mpd ! (p)reset matrix
4735 END DO
4736 ndown=0
4737 nweig=0
4738 cndl10=0.
4739 DO ieq=1,neq! loop over measurements
4740 ja=localequations(1,ioffq+ieq)
4741 jb=localequations(2,ioffq+ieq)
4742 rmeas=real(readbufferdatad(ja),mpd) ! data
4743 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4744 wght =1.0_mpd/rerr**2 ! weight from error
4745 nweig=nweig+1
4746 resid=rmeas-localcorrections(ioffq+ieq) ! subtract previous fit
4747 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4748 IF(iter <= 3) THEN
4749 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4750 wght=wght*chuber*rerr/abs(resid)
4751 ndown=ndown+1
4752 END IF
4753 ELSE ! Cauchy
4754 wght=wght/(1.0+(resid/rerr/cauchy)**2)
4755 END IF
4756 END IF
4757
4758 IF(lprnt.AND.iter /= 1.AND.nter /= 1) THEN
4759 chast=' '
4760 IF(abs(resid) > chuber*rerr) chast='* '
4761 IF(abs(resid) > 3.0*rerr) chast='** '
4762 IF(abs(resid) > 6.0*rerr) chast='***'
4763 IF(imeas == 0) WRITE(1,*) 'Second loop: accumulate'
4764 IF(imeas == 0) WRITE(1,103)
4765 imeas=imeas+1
4766 down=1.0/sqrt(wght)
4767 r1=resid/rerr
4768 r2=resid/down
4769 WRITE(1,104) imeas,rmeas,resid,rerr,r1,chast,r2
4770 END IF
4771103 FORMAT(' index corrvalue residuum sigma', &
4772 ' nresid cnresid')
4773104 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4774
4775 DO j=1,jb-ja-1 ! normal equations, local parameter loop
4776 ij=readbufferdatai(ja+j) ! local parameter index J
4777 blvec(ij)=blvec(ij)+wght*rmeas*real(readbufferdatad(ja+j),mpd)
4778 DO k=1,j
4779 ik=readbufferdatai(ja+k) ! local parameter index K
4780 jk=(ij*ij-ij)/2+ik ! index in symmetric matrix
4781 clmat(jk)=clmat(jk) & ! force double precision
4782 +wght*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)
4783 ! check for band matrix substructure
4784 IF (iter == 1) THEN
4785 id=iabs(ij-ik)+1
4786 im=min(ij,ik) ! upper/left border
4787 ibandh(id)=max(ibandh(id),im)
4788 im=min(nalc+1-ij,nalc+1-ik) ! lower/rght border (mirrored)
4789 ibandh(nalc+id)=max(ibandh(nalc+id),im)
4790 END IF
4791 END DO
4792 END DO
4793 END DO
4794 ! for non trivial fits check for bordered band matrix structure
4795 IF (iter == 1.AND.nalc > 5.AND.lfitbb > 0) THEN
4796 kx=-1
4797 kbdrx=0
4798 icmn=int(nalc,mpl)**3 ! cost (*6) should improve by at least factor 2
4799 ! upper/left border ?
4800 kbdr=0
4801 DO k=nalc,2,-1
4802 kbnd=k-2
4803 kbdr=max(kbdr,ibandh(k))
4804 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4805 IF (icost < icmn) THEN
4806 icmn=icost
4807 kx=k
4808 kbdrx=kbdr
4809 mside=1
4810 END IF
4811 END DO
4812 IF (kx < 0) THEN
4813 ! lower/right border instead?
4814 kbdr=0
4815 DO k=nalc,2,-1
4816 kbnd=k-2
4817 kbdr=max(kbdr,ibandh(k+nalc))
4818 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4819 IF (icost < icmn) THEN
4820 icmn=icost
4821 kx=k
4822 kbdrx=kbdr
4823 mside=2
4824 END IF
4825 END DO
4826 END IF
4827 IF (kx > 0) THEN
4828 mbnd=kx-2
4829 mbdr=kbdrx
4830 END IF
4831 END IF
4832
4833 IF (mbnd >= 0) THEN
4834 ! fast solution for border banded matrix (inverse for ICALCM>0)
4835 IF (nloopn == 1) THEN
4836 nbndr(mside)=nbndr(mside)+1
4837 nbdrx=max(nbdrx,mbdr)
4838 nbndx=max(nbndx,mbnd)
4839 END IF
4840
4841 inv=0
4842 IF (nloopn <= lfitnp.AND.iter == 1) inv=1 ! band part of inverse (for pulls)
4843 IF (icalcm == 1.OR.lprnt) inv=2 ! complete inverse
4844 IF (mside == 1) THEN
4845 CALL sqmibb(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4846 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
4847 ELSE
4848 CALL sqmibb2(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4849 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
4850 ENDIF
4851 ! log10(condition of band part)
4852 IF (evdmin > 0.0_mpl) cndl10=log10(real(evdmax/evdmin,mps))
4853 IF (lhist.AND.nloopn == 1) CALL hmpent(16,cndl10)
4854 ELSE
4855 ! full inversion and solution
4856 inv=2
4857 CALL sqminv(clmat,blvec,nalc,nrank,scdiag,scflag)
4858 END IF
4859 ! check for NaNs
4860 nan=0
4861 DO k=1, nalc
4862 IF ((.NOT.(blvec(k) <= 0.0_mpd)).AND. (.NOT.(blvec(k) > 0.0_mpd))) nan=nan+1
4863 END DO
4864
4865 IF(lprnt) THEN
4866 WRITE(1,*) ' '
4867 WRITE(1,*) 'Parameter determination:',nalc,' parameters,', ' rank=',nrank
4868 WRITE(1,*) '-----------------------'
4869 IF(ndown /= 0) WRITE(1,*) ' ',ndown,' data down-weighted'
4870 WRITE(1,*) ' '
4871 END IF
4872
4873 ! ----- third loop -------------------------------------------------
4874 ! calculate single residuals remaining after local fit and chi^2
4875
4876 summ=0.0_mpd
4877 suwt=0.0
4878 imeas=0
4879 DO ieq=1,neq! loop over measurements
4880 ja=localequations(1,ioffq+ieq)
4881 jb=localequations(2,ioffq+ieq)
4882 ist=localequations(3,ioffq+ieq)
4883 rmeas=real(readbufferdatad(ja),mpd) ! data (global contrib. subtracted)
4884 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4885 wght =1.0_mpd/rerr**2 ! weight from error
4886 rmloc=0.0 ! local fit result reset
4887 DO j=1,jb-ja-1 ! local parameter loop
4888 ij=readbufferdatai(ja+j)
4889 rmloc=rmloc+real(readbufferdatad(ja+j),mpd)*blvec(ij) ! local fit result
4890 END DO
4891 localcorrections(ioffq+ieq)=rmloc ! save local fit result
4892 rmeas=rmeas-rmloc ! reduced to residual
4893
4894 ! calculate pulls? (needs covariance matrix)
4895 IF(iter == 1.AND.inv > 0.AND.nloopn <= lfitnp) THEN
4896 dvar=0.0_mpd
4897 DO j=1,jb-ja-1
4898 ij=readbufferdatai(ja+j)
4899 jk=(ij*ij-ij)/2 ! index in symmetric matrix, row offset
4900 ! off diagonal (symmetric)
4901 DO k=1,j-1
4902 ik=readbufferdatai(ja+k)
4903 dvar=dvar+clmat(jk+ik)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)*2.0_mpd
4904 END DO
4905 ! diagonal
4906 dvar=dvar+clmat(jk+ij)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+j),mpd)
4907 END DO
4908 ! some variance left to define a pull?
4909 IF (0.999999_mpd/wght > dvar) THEN
4910 pull=rmeas/sqrt(1.0_mpd/wght-dvar)
4911 IF (lhist) THEN
4912 IF (jb < ist) THEN
4913 CALL hmpent(13,real(pull,mps)) ! histogram pull
4914 CALL gmpms(5,rec,real(pull,mps))
4915 ELSE
4916 CALL hmpent(14,real(pull,mps)) ! histogram pull
4917 END IF
4918 END IF
4919 ! monitoring
4920 IF (imonit /= 0) THEN
4921 IF (jb < ist) THEN
4922 ij=readbufferdatai(jb+1) ! group by first global label
4923 if (imonmd == 0) THEN
4924 irbin=min(measbins,max(1,int(pull*rerr/measres(ij)/measbinsize+0.5*real(measbins,mpd))))
4925 ELSE
4926 irbin=min(measbins,max(1,int(pull/measbinsize+0.5*real(measbins,mpd))))
4927 ENDIF
4928 irbin=irbin+measbins*(measindex(ij)-1+nummeas*iproc)
4929 meashists(irbin)=meashists(irbin)+1
4930 ENDIF
4931 ENDIF
4932 END IF
4933 END IF
4934
4935 IF(iter == 1.AND.jb < ist.AND.lhist) &
4936 CALL gmpms(4,rec,real(rmeas/rerr,mps)) ! residual (with global deriv.)
4937
4938 dchi2=wght*rmeas*rmeas
4939 ! DCHIT=DCHI2
4940 resid=rmeas
4941 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4942 IF(iter <= 3) THEN
4943 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4944 wght=wght*chuber*rerr/abs(resid)
4945 dchi2=2.0*chuber*(abs(resid)/rerr-0.5*chuber)
4946 END IF
4947 ELSE
4948 wght=wght/(1.0_mpd+(resid/rerr/cauchy)**2)
4949 dchi2=log(1.0_mpd+(resid/rerr/cauchy)**2)*cauchy**2
4950 END IF
4951 END IF
4952
4953 down=1.0/sqrt(wght)
4954
4955 ! SUWT=SUWT+DCHI2/DCHIT
4956 suwt=suwt+rerr/down
4957 IF(lprnt) THEN
4958 chast=' '
4959 IF(abs(resid) > chuber*rerr) chast='* '
4960 IF(abs(resid) > 3.0*rerr) chast='** '
4961 IF(abs(resid) > 6.0*rerr) chast='***'
4962 IF(imeas == 0) WRITE(1,*) 'Third loop: single residuals'
4963 IF(imeas == 0) WRITE(1,105)
4964 imeas=imeas+1
4965 r1=resid/rerr
4966 r2=resid/down
4967 IF(resid < 0.0) r1=-r1
4968 IF(resid < 0.0) r2=-r2
4969 WRITE(1,106) imeas,readbufferdatad(ja),rmeas,rerr,r1,chast,r2
4970 END IF
4971105 FORMAT(' index corrvalue residuum sigma', &
4972 ' nresid cnresid')
4973106 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4974
4975 IF(iter == nter) THEN
4976 readbufferdatad(ja)=real(rmeas,mpr8) ! store remaining residual
4977 resmax=max(resmax,abs(rmeas)/rerr)
4978 END IF
4979
4980 IF(iter == 1.AND.lhist) THEN
4981 IF (jb < ist) THEN
4982 CALL hmpent( 3,real(rmeas/rerr,mps)) ! histogram norm residual
4983 ELSE
4984 CALL hmpent(12,real(rmeas/rerr,mps)) ! histogram norm residual
4985 END IF
4986 END IF
4987 summ=summ+dchi2 ! accumulate chi-square sum
4988 END DO
4989
4990 ndf=neq-nrank
4991 resing=(real(nweig,mps)-real(suwt,mps))/real(nweig,mps)
4992 IF (lhist) THEN
4993 IF(iter == 1) CALL hmpent( 5,real(ndf,mps)) ! histogram Ndf
4994 IF(iter == 1) CALL hmpent(11,real(nalc,mps)) ! histogram Nlocal
4995 IF(nloopn == 2.AND.iter == nter) CALL hmpent(6,resing)
4996 END IF
4997 IF(lprnt) THEN
4998 WRITE(1,*) ' '
4999 WRITE(1,*) 'Chi^2=',summ,' at',ndf,' degrees of freedom: ', &
5000 '3-sigma limit is',chindl(3,ndf)*real(ndf,mps)
5001 WRITE(1,*) suwt,' is sum of factors, compared to',nweig, &
5002 ' Downweight fraction:',resing
5003 END IF
5004 IF(nan > 0) THEN
5005 nrej(1)=nrej(1)+1 ! count cases
5006 IF (nrec3 == huge(nrec3)) nrec3=nrc
5007 IF(lprnt) THEN
5008 WRITE(1,*) ' NaNs ', nalc, nrank, nan
5009 WRITE(1,*) ' ---> rejected!'
5010 END IF
5011 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-1 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5012 GO TO 90
5013 END IF
5014 IF(nrank /= nalc) THEN
5015 nrej(2)=nrej(2)+1 ! count cases
5016 IF (nrec3 == huge(nrec3)) nrec3=nrc
5017 IF(lprnt) THEN
5018 WRITE(1,*) ' rank deficit', nalc, nrank
5019 WRITE(1,*) ' ---> rejected!'
5020 END IF
5021 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-2 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5022 GO TO 90
5023 END IF
5024 IF(cndl10 > cndlmx) THEN
5025 nrej(3)=nrej(3)+1 ! count cases
5026 IF (nrec3 == huge(nrec3)) nrec3=nrc
5027 IF(lprnt) THEN
5028 WRITE(1,*) ' too large condition(band part) ', nalc, nrank, cndl10
5029 WRITE(1,*) ' ---> rejected!'
5030 END IF
5031 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-3 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5032 GO TO 90
5033 END IF
5034 IF(ndf <= 0) THEN
5035 nrej(4)=nrej(4)+1 ! count cases
5036 IF(lprnt) THEN
5037 WRITE(1,*) ' Ndf<=0', nalc, nrank, ndf
5038 WRITE(1,*) ' ---> rejected!'
5039 END IF
5040 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-4 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5041 GO TO 90
5042 END IF
5043
5044 chndf=real(summ/real(ndf,mpd),mps)
5045
5046 IF(iter == 1.AND.lhist) CALL hmpent(4,chndf) ! histogram chi^2/Ndf
5047 END DO ! outlier iteration loop
5048
5049 ! ----- reject eventually ------------------------------------------
5050
5051 IF(newite.AND.iterat == 2) THEN ! find record with largest Chi^2/Ndf
5052 IF(nrecp2 < 0.AND.chndf > writebufferdata(2,iproc+1)) THEN
5053 writebufferdata(2,iproc+1)=chndf
5054 writebufferinfo(8,iproc+1)=jrc
5055 writebufferinfo(9,iproc+1)=kfl
5056 END IF
5057 END IF
5058
5059 chichi=chindl(3,ndf)*real(ndf,mps)
5060 ! GF IF(SUMM.GT.50.0*CHICHI) THEN ! huge
5061 ! CHK CHICUT<0: NO cut (1st iteration)
5062 IF(chicut >= 0.0) THEN
5063 IF(summ > chhuge*chichi) THEN ! huge
5064 nrej(5)=nrej(5)+1 ! count cases with huge chi^2
5065 IF(lprnt) THEN
5066 WRITE(1,*) ' ---> rejected!'
5067 END IF
5068 GO TO 90
5069 END IF
5070
5071 IF(chicut > 0.0) THEN
5072 chlimt=chicut*chichi
5073 ! WRITE(*,*) 'chi^2 ',SUMM,CHLIMT,CHICUT,CHINDL(3,NDF),NDF
5074 IF(summ > chlimt) THEN
5075 IF(lprnt) THEN
5076 WRITE(1,*) ' ---> rejected!'
5077 END IF
5078 ! add to FVALUE
5079 dchi2=chlimt ! total contribution limit
5080 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
5081 nrej(6)=nrej(6)+1 ! count cases with large chi^2
5082 GO TO 90
5083 END IF
5084 END IF
5085 END IF
5086
5087 IF(lhuber > 1.AND.dwcut /= 0.0.AND.resing > dwcut) THEN
5088 ! add to FVALUE
5089 dchi2=summ ! total contribution
5090 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
5091 nrej(6)=nrej(6)+1 ! count cases with large chi^2
5092 ! WRITE(*,*) 'Downweight fraction cut ',RESING,DWCUT,SUMM
5093 IF(lprnt) THEN
5094 WRITE(1,*) ' ---> rejected!'
5095 END IF
5096 GO TO 90
5097 END IF
5098
5099 IF(newite.AND.iterat == 2) THEN ! find record with largest residual
5100 IF(nrecpr < 0.AND.resmax > writebufferdata(1,iproc+1)) THEN
5101 writebufferdata(1,iproc+1)=real(resmax,mps)
5102 writebufferinfo(6,iproc+1)=jrc
5103 writebufferinfo(7,iproc+1)=kfl
5104 END IF
5105 END IF
5106 ! 'track quality' per binary file: accepted records
5107 naccf(kfl)=naccf(kfl)+1
5108 ndff(kfl) =ndff(kfl) +ndf
5109 chi2f(kfl)=chi2f(kfl)+chndf
5110
5111 ! ----- fourth loop ------------------------------------------------
5112 ! update of global matrix and vector according to the "Millepede"
5113 ! principle, from the global/local information
5114
5115 summ=0.0_mpd
5116 DO ieq=1,neq! loop over measurements
5117 ja=localequations(1,ioffq+ieq)
5118 jb=localequations(2,ioffq+ieq)
5119 ist=localequations(3,ioffq+ieq)
5120 rmeas=real(readbufferdatad(ja),mpd) ! data residual
5121 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
5122 wght =1.0_mpd/rerr**2 ! weight from measurement error
5123 dchi2=wght*rmeas*rmeas ! least-square contribution
5124
5125 IF(nloopn /= 1.AND.lhuber /= 0) THEN ! check residual
5126 resid=abs(rmeas)
5127 IF(resid > chuber*rerr) THEN
5128 wght=wght*chuber*rerr/resid ! down-weighting
5129 dchi2=2.0*chuber*(resid/rerr-0.5*chuber) ! modified contribution
5130 END IF
5131 END IF
5132 ! sum up
5133 summ=summ+dchi2
5134
5135 ! global-global matrix contribution: add directly to gg-matrix
5136
5137 DO j=1,ist-jb
5138 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5139 IF (readbufferdatad(jb+j) == 0.0_mpd) cycle ! skip zero global derivatives
5140 IF(ivgbj > 0) THEN
5141 globalvector(ioffb+ivgbj)=globalvector(ioffb+ivgbj) &
5142 +dw1*wght*rmeas*real(readbufferdatad(jb+j),mpd) ! vector !!! reverse
5143 globalcounter(ioffb+ivgbj)=globalcounter(ioffb+ivgbj)+1
5144 IF(icalcm == 1) THEN
5145 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5146 DO k=1,j
5148 IF(ivgbk > 0) THEN
5149 ike=backindexusage(ioffe+ivgbk) ! get index of index, non-zero
5150 ia=max(ije,ike) ! larger
5151 ib=min(ije,ike) ! smaller
5152 ij=ib+(ia*ia-ia)/2
5153 writebufferupdates(ioffd+ij)=writebufferupdates(ioffd+ij) &
5154 -dw1*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(jb+k),mpd)
5155 END IF
5156 END DO
5157 END IF
5158 END IF
5159 END DO
5160
5161 ! normal equations - rectangular matrix for global/local pars
5162 ! global-local matrix contribution: accumulate rectangular matrix
5163 IF (icalcm /= 1) cycle
5164 DO j=1,ist-jb
5165 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5166 IF(ivgbj > 0) THEN
5167 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5168 DO k=1,jb-ja-1
5169 ik=readbufferdatai(ja+k) ! local index
5170 jk=ik+(ije-1)*nalc ! matrix index
5172 dw2*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(ja+k),mpd)
5174 END DO
5175 END IF
5176 END DO
5177 END DO
5178 ! add to total objective function
5179 CALL addsums(iproc+1, summ, ndf, dw1)
5180
5181 ! ----- final matrix update ----------------------------------------
5182 ! update global matrices and vectors
5183 IF(icalcm /= 1) GO TO 90 ! matrix update
5184 ! (inverse local matrix) * (rectang. matrix) -> CORM
5185 ! T
5186 ! resulting symmetrix matrix = G * Gamma^{-1} * G
5187
5188 ! check sparsity of localGlobalMatrix (with par. groups)
5189 isize=nalc+nalg+1 ! row/clolumn offsets
5190 ! check rows
5191 k=0 ! offset
5192 DO i=1, nalg
5193 localglobalstructure(i)=isize
5194 DO j=1, nalc
5195 IF (localglobalmap(k+j) > 0) THEN
5196 localglobalstructure(isize+1)=j ! column
5197 localglobalstructure(isize+2)=k+j ! index
5198 isize=isize+2
5199 ENDIF
5200 END DO
5201 k=k+nalc
5202 END DO
5203 ! <50% non-zero elements?
5204 IF (isize-localglobalstructure(1) < nalc*nalg) THEN
5205 ! check columns (too)
5206 DO j=1, nalc
5207 localglobalstructure(nalg+j)=isize
5208 k=0 ! offset
5209 DO i=1, nalg
5210 IF (localglobalmap(k+j) > 0) THEN
5211 localglobalstructure(isize+1)=i ! row
5212 localglobalstructure(isize+2)=k+j ! index
5213 isize=isize+2
5214 ENDIF
5215 k=k+nalc
5216 END DO
5217 END DO
5218 localglobalstructure(nalg+nalc+1)=isize
5220 ELSE
5221 CALL dbavat(clmat,localglobalmatrix,writebufferupdates(ioffd+1),nalc,nalg,1)
5222 END IF
5223 ! (rectang. matrix) * (local param vector) -> CORV
5224 ! resulting vector = G * q (q = local parameter)
5225 ! CALL DBGAX(DQ(IGLMA/2+1),BLVEC,DQ(ICORV/2+1),NALG,NALC) ! not done
5226 ! the vector update is not done, because after local fit it is zero!
5227
5228 ! update cache status
5229 writebufferinfo(1,iproc+1)=writebufferinfo(1,iproc+1)+1
5230 writebufferinfo(2,iproc+1)=writebufferinfo(2,iproc+1)+ngg
5231 writebufferinfo(3,iproc+1)=writebufferinfo(3,iproc+1)+ngrp+3
5232 ! check free space
5233 nfred=writebufferheader(-1)-writebufferinfo(2,iproc+1)-writebufferheader(-2)
5235 IF (nfred < 0.OR.nfrei < 0) THEN ! need to flush
5236 nb=writebufferinfo(1,iproc+1)
5237 joffd=writebufferheader(-1)*iproc ! offset data
5238 joffi=writebufferheader(1)*iproc+3 ! offset indices
5239 used=real(writebufferinfo(2,iproc+1),mps)/real(writebufferheader(-1),mps)
5240 writebufferinfo(4,iproc+1)=writebufferinfo(4,iproc+1) +nint(1000.0*used,mpi)
5241 used=real(writebufferinfo(3,iproc+1),mps)/real(writebufferheader(1),mps)
5242 writebufferinfo(5,iproc+1)=writebufferinfo(5,iproc+1) +nint(1000.0*used,mpi)
5243 !$OMP CRITICAL
5246
5247 DO ib=1,nb
5248 nalg=writebufferindices(joffi-1)
5249 il=1 ! row in update matrix
5250 DO in=1,writebufferindices(joffi)
5251 i=writebufferindices(joffi+in)
5252 j=writebufferindices(joffi+1) ! 1. group
5253 iprc=ijprec(i,j) ! group pair precision
5254 jl=1 ! col in update matrix
5255 ! start (rows) for continous groups
5256 j1=j
5257 jl1=jl
5258 ! other groups for row
5259 DO jn=2,in
5261 jnx=writebufferindices(joffi+jn) ! next group
5262 iprcnx=ijprec(i,jnx) ! group pair precision
5263 ! end of continous groups?
5264 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5265 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5266 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5267 ! restart continous groups
5268 j1=jnx ! new 1. column
5269 jl1=jl
5270 iprc=iprcnx
5271 END IF
5272 j=jnx ! last group
5273 END DO
5274 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5275 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5277 END DO
5278 joffd=joffd+(il*il-il)/2
5279 joffi=joffi+writebufferindices(joffi)+3
5280 END DO
5281 !$OMP END CRITICAL
5282 ! reset counter, pointers
5283 DO k=1,3
5284 writebufferinfo(k,iproc+1)=0
5285 END DO
5286 END IF
5287
528890 IF(lprnt) THEN
5289 WRITE(1,*) ' '
5290 WRITE(1,*) '------------------ End of printout for record',nrc
5291 WRITE(1,*) ' '
5292 END IF
5293
5294 DO i=1,nalg ! reset global index array
5295 iext=globalindexusage(ioffc+i)
5296 backindexusage(ioffe+iext)=0
5297 END DO
5298
5299 END DO
5300 !$OMP END PARALLEL DO
5301
5302 IF (icalcm == 1) THEN
5303 ! flush remaining matrices
5304 DO k=1,mthrd ! update statistics
5306 used=real(writebufferinfo(2,k),mps)/real(writebufferheader(-1),mps)
5307 writebufferinfo(4,k)=writebufferinfo(4,k)+nint(1000.0*used,mpi)
5310 writebufferinfo(4,k)=0
5312 used=real(writebufferinfo(3,k),mps)/real(writebufferheader(1),mps)
5313 writebufferinfo(5,k)=writebufferinfo(5,k)+nint(1000.0*used,mpi)
5316 writebufferinfo(5,k)=0
5317 END DO
5318
5319 !$OMP PARALLEL &
5320 !$OMP DEFAULT(PRIVATE) &
5321 !$OMP SHARED(writeBufferHeader,writeBufferInfo,writeBufferIndices,writeBufferUpdates,MTHRD) &
5322 !$OMP SHARED(globalAllParToGroup,globalAllIndexGroups,nspc)
5323 iproc=0
5324 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5325 DO jproc=0,mthrd-1
5326 nb=writebufferinfo(1,jproc+1)
5327 ! print *, ' flush end ', JPROC, NRC, NB
5328 joffd=writebufferheader(-1)*jproc ! offset data
5329 joffi=writebufferheader(1)*jproc+3 ! offset indices
5330 DO ib=1,nb
5331 ! print *, ' buf end ', JPROC,IB,writeBufferIndices(JOFFI-2),writeBufferIndices(JOFFI)
5332 nalg=writebufferindices(joffi-1)
5333 il=1 ! row in update matrix
5334 DO in=1,writebufferindices(joffi)
5335 i=writebufferindices(joffi+in)
5336 !$ IF (MOD(I,MTHRD).EQ.IPROC) THEN
5337 j=writebufferindices(joffi+1) ! 1. group
5338 iprc=ijprec(i,j) ! group pair precision
5339 jl=1 ! col in update matrix
5340 ! start (rows) for continous groups
5341 j1=j
5342 jl1=jl
5343 ! other groups for row
5344 DO jn=2,in
5346 jnx=writebufferindices(joffi+jn) ! next group
5347 iprcnx=ijprec(i,jnx) ! group pair precision
5348 ! end of continous groups?
5349 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5350 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5351 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5352 ! restart continous groups
5353 j1=jnx ! new 1. column
5354 jl1=jl
5355 iprc=iprcnx
5356 END IF
5357 j=jnx ! last group
5358 END DO
5359 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5360 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5361 !$ END IF
5363 END DO
5364 joffd=joffd+(il*il-il)/2
5365 joffi=joffi+writebufferindices(joffi)+3
5366 END DO
5367 END DO
5368 !$OMP END PARALLEL
5369 END IF
5370
5371 IF(newite.AND.iterat == 2) THEN ! get worst records (for printrecord -1 -1)
5372 IF (nrecpr < 0) THEN
5373 DO k=1,mthrd
5374 IF (writebufferdata(1,k) > value1) THEN
5377 END IF
5378 END DO
5379 END IF
5380 IF (nrecp2 < 0) THEN
5381 DO k=1,mthrd
5382 IF (writebufferdata(2,k) > value2) THEN
5385 END IF
5386 END DO
5387 END IF
5388 END IF
5389
5390END SUBROUTINE loopbf
5391
5392!***********************************************************************
5393
5396SUBROUTINE prtrej(lun)
5397 USE mpmod
5398
5399 IMPLICIT NONE
5400 INTEGER(mpi), INTENT(IN) :: lun
5401
5402 IF (nrejec(1)>0) WRITE(lun,*) nrejec(1), ' (local solution contains NaNs)'
5403 IF (nrejec(2)>0) WRITE(lun,*) nrejec(2), ' (local matrix with rank deficit)'
5404 IF (nrejec(3)>0) WRITE(lun,*) nrejec(3), ' (local matrix with ill condition)'
5405 IF (nrejec(4)>0) WRITE(lun,*) nrejec(4), ' (local fit with Ndf=0)'
5406 IF (nrejec(5)>0) WRITE(lun,*) nrejec(5), ' (local fit with huge Chi2(Ndf))'
5407 IF (nrejec(6)>0) WRITE(lun,*) nrejec(6), ' (local fit with large Chi2(Ndf))'
5408
5409END SUBROUTINE prtrej
5410
5411!***********************************************************************
5412
5425SUBROUTINE prtglo
5426 USE mpmod
5427
5428 IMPLICIT NONE
5429 REAL(mps):: dpa
5430 REAL(mps):: err
5431 REAL(mps):: gcor
5432 INTEGER(mpi) :: i
5433 INTEGER(mpi) :: icom
5434 INTEGER(mpl) :: icount
5435 INTEGER(mpi) :: ie
5436 INTEGER(mpi) :: iev
5437 INTEGER(mpi) :: ij
5438 INTEGER(mpi) :: imin
5439 INTEGER(mpi) :: iprlim
5440 INTEGER(mpi) :: isub
5441 INTEGER(mpi) :: itgbi
5442 INTEGER(mpi) :: itgbl
5443 INTEGER(mpi) :: ivgbi
5444 INTEGER(mpi) :: j
5445 INTEGER(mpi) :: label
5446 INTEGER(mpi) :: lup
5447 REAL(mps):: par
5448 LOGICAL :: lowstat
5449
5450 REAL(mpd):: diag
5451 REAL(mpd)::gmati
5452 REAL(mpd)::gcor2
5453 INTEGER(mpi) :: labele(3)
5454 REAL(mps):: compnt(3)
5455 SAVE
5456 ! ...
5457
5458 lup=09
5459 CALL mvopen(lup,'millepede.res')
5460
5461 WRITE(*,*) ' '
5462 WRITE(*,*) ' Result of fit for global parameters'
5463 WRITE(*,*) ' ==================================='
5464 WRITE(*,*) ' '
5465
5466 WRITE(*,101)
5467
5468 WRITE(lup,*) 'Parameter ! first 3 elements per line are', &
5469 ' significant (if used as input)'
5470
5471
5472 iprlim=10
5473 DO itgbi=1,ntgb ! all parameter variables
5474 itgbl=globalparlabelindex(1,itgbi)
5475 ivgbi=globalparlabelindex(2,itgbi)
5476 icom=globalparcomments(itgbi) ! comment
5477 IF (icom > 0) WRITE(lup,113) listcomments(icom)%text
5478 par=real(globalparameter(itgbi),mps) ! initial value
5479 icount=0 ! counts
5480 lowstat = .false.
5481 IF(ivgbi > 0) THEN
5482 icount=globalcounter(ivgbi) ! used in last iteration
5483 lowstat = (icount < mreqena) ! too few accepted entries
5484 dpa=real(globalparameter(itgbi)-globalparstart(itgbi),mps) ! difference
5485 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5486 gmati=globalmatd(globalrowoffsets(ivgbi)+ivgbi)
5487 err=sqrt(abs(real(gmati,mps)))
5488 IF(gmati < 0.0_mpd) err=-err
5489 diag=workspacediag(ivgbi)
5490 gcor=-1.0
5491 IF(gmati*diag > 0.0_mpd) THEN ! global correlation
5492 gcor2=1.0_mpd-1.0_mpd/(gmati*diag)
5493 IF(gcor2 >= 0.0_mpd.AND.gcor2 <= 1.0_mpd) gcor=real(sqrt(gcor2),mps)
5494 END IF
5495 END IF
5496 END IF
5497 IF(ipcntr > 1) icount=globalparlabelcounter(itgbi) ! from binary files
5498 IF(lowstat) icount=-(icount+1) ! flag 'lowstat' with icount < 0
5499 IF(ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
5500 IF(itgbi <= iprlim) THEN
5501 IF(ivgbi <= 0) THEN
5502 WRITE(* ,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5503 ELSE
5504 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5505 IF (igcorr == 0) THEN
5506 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5507 ELSE
5508 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5509 END IF
5510 ELSE
5511 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5512 END IF
5513 END IF
5514 ELSE IF(itgbi == iprlim+1) THEN
5515 WRITE(* ,*) '... (further printout suppressed, but see log file)'
5516 END IF
5517
5518 ! file output
5519 IF(ivgbi <= 0) THEN
5520 IF (ipcntr /= 0) THEN
5521 WRITE(lup,110) itgbl,par,real(globalparpresigma(itgbi),mps),icount
5522 ELSE
5523 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5524 END IF
5525 ELSE
5526 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5527 IF (ipcntr /= 0) THEN
5528 WRITE(lup,112) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,icount
5529 ELSE IF (igcorr /= 0) THEN
5530 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5531 ELSE
5532 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5533 END IF
5534 ELSE
5535 IF (ipcntr /= 0) THEN
5536 WRITE(lup,111) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,icount
5537 ELSE
5538 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5539 END IF
5540 END IF
5541 END IF
5542 END DO
5543 rewind lup
5544 CLOSE(unit=lup)
5545
5546 IF(metsol == 2) THEN ! diagonalisation: write eigenvectors
5547 CALL mvopen(lup,'millepede.eve')
5548 imin=1
5549 DO i=nagb,1,-1
5550 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
5551 imin=i ! index of smallest pos. eigenvalue
5552 EXIT
5553 ENDIF
5554 END DO
5555 iev=0
5556
5557 DO isub=0,min(15,imin-1)
5558 IF(isub < 10) THEN
5559 i=imin-isub
5560 ELSE
5561 i=isub-9
5562 END IF
5563
5564 ! DO I=IMIN,MAX(1,IMIN-9),-1 ! backward loop, up to 10 vectors
5565 WRITE(*,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5566 WRITE(lup,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5567 DO j=1,nagb
5568 ij=j+(i-1)*nagb ! index with eigenvector array
5569 IF(j <= nvgb) THEN
5570 itgbi=globalparvartototal(j)
5571 label=globalparlabelindex(1,itgbi)
5572 ELSE
5573 label=nvgb-j ! label negative for constraints
5574 END IF
5575 iev=iev+1
5576 labele(iev)=label
5577 compnt(iev)=real(workspaceeigenvectors(ij),mps) ! component
5578 IF(iev == 3) THEN
5579 WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5580 iev=0
5581 END IF
5582 END DO
5583 IF(iev /= 0) WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5584 iev=0
5585 WRITE(lup,*) ' '
5586 END DO
5587 CLOSE(unit=lup)
5588
5589 END IF
5590
5591101 FORMAT(1x,' label parameter presigma differ', &
5592 ' error'/ 1x,'-----------',4x,4('-------------'))
5593102 FORMAT(i10,2x,4g14.5,f8.3)
5594103 FORMAT(3(i11,f11.7,2x))
5595110 FORMAT(i10,2x,2g14.5,28x,i12)
5596111 FORMAT(i10,2x,3g14.5,14x,i12)
5597112 FORMAT(i10,2x,4g14.5,i12)
5598113 FORMAT('!',a)
5599END SUBROUTINE prtglo ! print final log file
5600
5601!***********************************************************************
5602
5612SUBROUTINE prtstat
5613 USE mpmod
5614 USE mpdalc
5615
5616 IMPLICIT NONE
5617 REAL(mps):: par
5618 REAL(mps):: presig
5619 INTEGER(mpi) :: icom
5620 INTEGER(mpl) :: icount
5621 INTEGER(mpi) :: ifrst
5622 INTEGER(mpi) :: ilast
5623 INTEGER(mpi) :: inext
5624 INTEGER(mpi) :: itgbi
5625 INTEGER(mpi) :: itgbl
5626 INTEGER(mpi) :: itpgrp
5627 INTEGER(mpi) :: ivgbi
5628 INTEGER(mpi) :: lup
5629 INTEGER(mpi) :: icgrp
5630 INTEGER(mpi) :: ipgrp
5631 INTEGER(mpi) :: j
5632 INTEGER(mpi) :: jpgrp
5633 INTEGER(mpi) :: k
5634 INTEGER(mpi) :: label1
5635 INTEGER(mpi) :: label2
5636 INTEGER(mpi) :: ncon
5637 INTEGER(mpi) :: npair
5638 INTEGER(mpi) :: nstep
5639 CHARACTER :: c1
5640
5641 INTEGER(mpl):: length
5642
5643 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
5644
5645 INTERFACE ! needed for assumed-shape dummy arguments
5646 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
5647 USE mpdef
5648 INTEGER(mpi), INTENT(IN) :: ipgrp
5649 INTEGER(mpi), INTENT(OUT) :: npair
5650 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
5651 END SUBROUTINE ggbmap
5652 END INTERFACE
5653
5654 SAVE
5655 ! ...
5656
5657 lup=09
5658 CALL mvopen(lup,'millepede.res')
5659 WRITE(lup,*) '*** Results of checking input only, no solution performed ***'
5660 WRITE(lup,*) '! === global parameters ==='
5661 WRITE(lup,*) '! fixed-1: by pre-sigma, -2: by entries cut, -3: by iterated entries cut'
5662 IF (ipcntr < 0) THEN
5663 WRITE(lup,*) '! Label Value Pre-sigma SkippedEntries Cons. group Status '
5664 ELSE
5665 WRITE(lup,*) '! Label Value Pre-sigma Entries Cons. group Status '
5666 END IF
5667 !iprlim=10
5668 DO itgbi=1,ntgb ! all parameter variables
5669 itgbl=globalparlabelindex(1,itgbi)
5670 ivgbi=globalparlabelindex(2,itgbi)
5671 icom=globalparcomments(itgbi) ! comment
5672 IF (icom > 0) WRITE(lup,117) listcomments(icom)%text
5673 c1=' '
5674 IF (globalparlabelindex(3,itgbi) == itgbl) c1='>'
5675 par=real(globalparameter(itgbi),mps) ! initial value
5676 presig=real(globalparpresigma(itgbi),mps) ! initial presigma
5677 icount=globalparlabelcounter(itgbi) ! from binary files
5678 IF (ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
5679 icgrp=globalparcons(itgbi) ! constraints group
5680
5681 IF (ivgbi <= 0) THEN
5682 ! not used
5683 IF (ivgbi == -4) THEN
5684 WRITE(lup,116) c1,itgbl,par,presig,icount,icgrp
5685 ELSE
5686 WRITE(lup,110) c1,itgbl,par,presig,icount,icgrp,ivgbi
5687 END IF
5688 ELSE
5689 ! variable
5690 WRITE(lup,111) c1,itgbl,par,presig,icount,icgrp
5691 END IF
5692 END DO
5693 ! appearance statistics
5694 IF (icheck > 1) THEN
5695 WRITE(lup,*) '!.'
5696 WRITE(lup,*) '!.Appearance statistics '
5697 WRITE(lup,*) '!. Label First file and record Last file and record #files #paired-par'
5698 DO itgbi=1,ntgb
5699 itpgrp=globalparlabelindex(4,itgbi)
5700 IF (itpgrp > 0) THEN
5701 WRITE(lup,112) globalparlabelindex(1,itgbi), (appearancecounter(itgbi*5+k), k=-4,0), paircounter(itpgrp)
5702 ELSE ! 'empty' parameter
5703 WRITE(lup,112) globalparlabelindex(1,itgbi)
5704 END IF
5705 END DO
5706 END IF
5707 IF (ncgrp > 0) THEN
5708 WRITE(lup,*) '* === constraint groups ==='
5709 IF (icheck == 1) THEN
5710 WRITE(lup,*) '* Group #Cons. Entries First label Last label'
5711 ELSE
5712 WRITE(lup,*) '* Group #Cons. Entries First label Last label Paired label range'
5713 length=ntpgrp+ncgrp
5714 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
5715 END IF
5716 DO icgrp=1, ncgrp
5717 IF (matconsgroups(2,icgrp) <= matconsgroups(3,icgrp)) THEN
5718 label1=globalparlabelindex(1,globalparvartototal(matconsgroups(2,icgrp))) ! first label
5719 label2=globalparlabelindex(1,globalparvartototal(matconsgroups(3,icgrp))) ! last label
5720 ELSE ! empty group/cons.
5721 label1=0
5722 label2=0
5723 END IF
5724 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
5725 WRITE(lup,113) icgrp, ncon,vecconsgroupcounts(icgrp),label1,label2
5726 IF (icheck > 1 .AND. label1 > 0) THEN
5727 ipgrp=globalparlabelindex(4,globalparvartototal(matconsgroups(2,icgrp))) ! first par. group
5728 ! get paired parameter groups
5729 CALL ggbmap(ntpgrp+icgrp,npair,vecpairedpargroups)
5730 vecpairedpargroups(npair+1)=0
5731 ifrst=0
5732 nstep=1
5733 DO j=1, npair
5734 jpgrp=vecpairedpargroups(j)
5735 inext=globaltotindexgroups(1,jpgrp)
5736 DO k=1,globaltotindexgroups(2,jpgrp)
5737 ! end of continous region ?
5738 IF (ifrst /= 0.AND.inext /= (ilast+nstep)) THEN
5739 label1=globalparlabelindex(1,ifrst)
5740 label2=globalparlabelindex(1,ilast)
5741 WRITE(lup,114) label1, label2
5742 ifrst=0
5743 END IF
5744 ! skip 'self-correlations'
5745 IF (globalparcons(inext) /= icgrp) THEN
5746 IF (ifrst == 0) ifrst=inext
5747 ilast=inext
5748 END IF
5749 inext=inext+1
5750 nstep=1
5751 END DO
5752 ! skip 'empty' parameter
5753 IF (jpgrp == vecpairedpargroups(j+1)-1) THEN
5754 nstep=globaltotindexgroups(1,vecpairedpargroups(j+1)) &
5755 -(globaltotindexgroups(1,jpgrp)+globaltotindexgroups(2,jpgrp)-1)
5756 END IF
5757 END DO
5758 IF (ifrst /= 0) THEN
5759 label1=globalparlabelindex(1,ifrst)
5760 label2=globalparlabelindex(1,ilast)
5761 WRITE(lup,114) label1, label2
5762 END IF
5763 END IF
5764 END DO
5765 IF (icheck > 1) THEN
5766 WRITE(lup,*) '*.'
5767 WRITE(lup,*) '*.Appearance statistics '
5768 WRITE(lup,*) '*. Group First file and record Last file and record #files'
5769 DO icgrp=1, ncgrp
5770 WRITE(lup,115) icgrp, (appearancecounter((ntgb+icgrp)*5+k), k=-4,0)
5771 END DO
5772 END IF
5773 END IF
5774
5775 rewind lup
5776 CLOSE(unit=lup)
5777
5778110 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' fixed',i2)
5779111 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' variable')
5780112 FORMAT(' !.',i10,6i11)
5781113 FORMAT(' * ',i6,i8,3i12)
5782114 FORMAT(' *:',48x,i12,' ..',i12)
5783115 FORMAT(' *.',i10,5i11)
5784116 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' redundant')
5785117 FORMAT(' !!',a)
5786END SUBROUTINE prtstat ! print input statistics
5787
5788
5802
5803SUBROUTINE avprds(n,l,x,is,ie,b)
5804 USE mpmod
5805
5806 IMPLICIT NONE
5807 INTEGER(mpi) :: i
5808 INTEGER(mpi) :: ia
5809 INTEGER(mpi) :: ia2
5810 INTEGER(mpi) :: ib
5811 INTEGER(mpi) :: ib2
5812 INTEGER(mpi) :: in
5813 INTEGER(mpi) :: ipg
5814 INTEGER(mpi) :: iproc
5815 INTEGER(mpi) :: ir
5816 INTEGER(mpi) :: j
5817 INTEGER(mpi) :: ja
5818 INTEGER(mpi) :: ja2
5819 INTEGER(mpi) :: jb
5820 INTEGER(mpi) :: jb2
5821 INTEGER(mpi) :: jn
5822 INTEGER(mpi) :: lj
5823
5824 INTEGER(mpi), INTENT(IN) :: n
5825 INTEGER(mpl), INTENT(IN) :: l
5826 REAL(mpd), INTENT(IN) :: x(n)
5827 INTEGER(mpi), INTENT(IN) :: is
5828 INTEGER(mpi), INTENT(IN) :: ie
5829 REAL(mpd), INTENT(OUT) :: b(n)
5830 INTEGER(mpl) :: k
5831 INTEGER(mpl) :: kk
5832 INTEGER(mpl) :: ku
5833 INTEGER(mpl) :: ll
5834 INTEGER(mpl) :: indij
5835 INTEGER(mpl) :: indid
5836 INTEGER(mpl) :: ij
5837 INTEGER(mpi) :: ichunk
5838 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
5839 SAVE
5840 ! ...
5841
5842 ichunk=min((n+mthrd-1)/mthrd/8+1,128)
5843 IF(matsto /= 2) THEN
5844 ! full or unpacked (block diagonal) symmetric matrix
5845 ! parallelize row loop
5846 ! private copy of B(N) for each thread, combined at end, init with 0.
5847 ! slot of 128 'I' for next idle thread
5848 !$OMP PARALLEL DO &
5849 !$OMP PRIVATE(J,IJ) &
5850 !$OMP SCHEDULE(DYNAMIC,ichunk)
5851 DO i=1,n
5852 ij=globalrowoffsets(i+l)+l
5853 DO j=is,min(i,ie)
5854 b(i)=b(i)+globalmatd(ij+j)*x(j)
5855 END DO
5856 END DO
5857 !$OMP END PARALLEL DO
5858
5859 !$OMP PARALLEL DO &
5860 !$OMP PRIVATE(J,IJ) &
5861 !$OMP REDUCTION(+:B) &
5862 !$OMP SCHEDULE(DYNAMIC,ichunk)
5863 DO i=is,ie
5864 ij=globalrowoffsets(i+l)+l
5865 DO j=1,i-1
5866 b(j)=b(j)+globalmatd(ij+j)*x(i)
5867 END DO
5868 END DO
5869 !$OMP END PARALLEL DO
5870 ELSE
5871 ! sparse, compressed matrix
5872 IF(sparsematrixoffsets(2,1) /= n) THEN
5873 CALL peend(24,'Aborted, vector/matrix size mismatch')
5874 stop 'AVPRDS: mismatched vector and matrix'
5875 END IF
5876 ! parallelize row (group) loop
5877 ! slot of 1024 'I' for next idle thread
5878 !$OMP PARALLEL DO &
5879 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
5880 !$OMP PRIVATE(IA,IB,IN,JA,JB,IA2,IB2,JA2,JB2) &
5881 !$OMP REDUCTION(+:B) &
5882 !$OMP SCHEDULE(DYNAMIC,ichunk)
5883 DO ipg=1,napgrp
5884 iproc=0
5885 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5886 ! row group
5887 ia=globalallindexgroups(ipg) ! first (global) row
5888 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
5889 in=ib-ia+1 ! number of rows
5890 ! overlap
5891 ia2=max(ia,is)
5892 ib2=min(ib,ie)
5893 ! diagonal elements
5894 IF (ia2 <= ib2) b(ia2:ib2)=b(ia2:ib2)+globalmatd(ia2:ib2)*x(ia2:ib2)
5895 ! off-diagonals double precision
5896 ir=ipg
5897 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5898 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5899 ku=sparsematrixoffsets(1,ir+1)-kk
5900 indid=kk
5901 indij=ll
5902 IF (ku > 0) THEN
5903 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5904 DO i=ia,ib
5905 IF (i <= ie.AND.i >= is) THEN
5906 DO k=1,ku
5907 j=sparsematrixcolumns(indid+k)
5908 b(j)=b(j)+globalmatd(indij+k)*x(i)
5909 END DO
5910 END IF
5911 DO k=1,ku
5912 j=sparsematrixcolumns(indid+k)
5913 IF (j <= ie.AND.j >= is) THEN
5914 b(i)=b(i)+globalmatd(indij+k)*x(j)
5915 END IF
5916 END DO
5917 indij=indij+ku
5918 END DO
5919 ELSE
5920 ! regions of continous column groups
5921 DO k=2,ku-2,2
5922 j=sparsematrixcolumns(indid+k) ! first group
5923 ja=globalallindexgroups(j) ! first (global) column
5924 lj=sparsematrixcolumns(indid+k-1) ! region offset
5925 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5926 jb=ja+jn-1 ! last (global) column
5927 ja2=max(ja,is)
5928 jb2=min(jb,ie)
5929 IF (ja2 <= jb2) THEN
5930 lj=1 ! index (in group region)
5931 DO i=ia,ib
5932 b(i)=b(i)+dot_product(globalmatd(indij+lj+ja2-ja:indij+lj+jb2-ja),x(ja2:jb2))
5933 lj=lj+jn
5934 END DO
5935 END IF
5936 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5937 lj=1
5938 DO j=ja,jb
5939 b(j)=b(j)+dot_product(globalmatd(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),x(ia2:ib2))
5940 lj=lj+1
5941 END DO
5942 END IF
5943 indij=indij+in*jn
5944 END DO
5945 END IF
5946 END IF
5947 ! mixed precision
5948 IF (nspc > 1) THEN
5949 ir=ipg+napgrp+1 ! off-diagonals single precision
5950 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5951 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5952 ku=sparsematrixoffsets(1,ir+1)-kk
5953 indid=kk
5954 indij=ll
5955 IF (ku == 0) cycle
5956 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5957 DO i=ia,ib
5958 IF (i <= ie.AND.i >= is) THEN
5959 DO k=1,ku
5960 j=sparsematrixcolumns(indid+k)
5961 b(j)=b(j)+globalmatf(indij+k)*x(i)
5962 END DO
5963 END IF
5964 DO k=1,ku
5965 j=sparsematrixcolumns(indid+k)
5966 IF (j <= ie.AND.j >= is) THEN
5967 b(i)=b(i)+globalmatf(indij+k)*x(j)
5968 END IF
5969 END DO
5970 indij=indij+ku
5971 END DO
5972 ELSE
5973 ! regions of continous column groups
5974 DO k=2,ku-2,2
5975 j=sparsematrixcolumns(indid+k) ! first group
5976 ja=globalallindexgroups(j) ! first (global) column
5977 lj=sparsematrixcolumns(indid+k-1) ! region offset
5978 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5979 jb=ja+jn-1 ! last (global) column
5980 ja2=max(ja,is)
5981 jb2=min(jb,ie)
5982 IF (ja2 <= jb2) THEN
5983 lj=1 ! index (in group region)
5984 DO i=ia,ib
5985 b(i)=b(i)+dot_product(real(globalmatf(indij+lj+ja2-ja:indij+lj+jb2-ja),mpd),x(ja2:jb2))
5986 lj=lj+jn
5987 END DO
5988 END IF
5989 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5990 lj=1
5991 DO j=ja,jb
5992 b(j)=b(j)+dot_product(real(globalmatf(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),mpd),x(ia2:ib2))
5993 lj=lj+1
5994 END DO
5995 END IF
5996 indij=indij+in*jn
5997 END DO
5998 END IF
5999 END IF
6000 END DO
6001 ENDIF
6002
6003END SUBROUTINE avprds
6004
6016
6017SUBROUTINE avprd0(n,l,x,b)
6018 USE mpmod
6019
6020 IMPLICIT NONE
6021 INTEGER(mpi) :: i
6022 INTEGER(mpi) :: ia
6023 INTEGER(mpi) :: ib
6024 INTEGER(mpi) :: in
6025 INTEGER(mpi) :: ipg
6026 INTEGER(mpi) :: iproc
6027 INTEGER(mpi) :: ir
6028 INTEGER(mpi) :: j
6029 INTEGER(mpi) :: ja
6030 INTEGER(mpi) :: jb
6031 INTEGER(mpi) :: jn
6032 INTEGER(mpi) :: lj
6033
6034 INTEGER(mpi), INTENT(IN) :: n
6035 INTEGER(mpl), INTENT(IN) :: l
6036 REAL(mpd), INTENT(IN) :: x(n)
6037 REAL(mpd), INTENT(OUT) :: b(n)
6038 INTEGER(mpl) :: k
6039 INTEGER(mpl) :: kk
6040 INTEGER(mpl) :: ku
6041 INTEGER(mpl) :: ll
6042 INTEGER(mpl) :: indij
6043 INTEGER(mpl) :: indid
6044 INTEGER(mpl) :: ij
6045 INTEGER(mpi) :: ichunk
6046 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
6047 SAVE
6048 ! ...
6049 !$ DO i=1,n
6050 !$ b(i)=0.0_mpd ! reset 'global' B()
6051 !$ END DO
6052 ichunk=min((n+mthrd-1)/mthrd/8+1,1024)
6053 IF(matsto /= 2) THEN
6054 ! full or unpacked (block diagonal) symmetric matrix
6055 ! parallelize row loop
6056 ! private copy of B(N) for each thread, combined at end, init with 0.
6057 ! slot of 1024 'I' for next idle thread
6058 !$OMP PARALLEL DO &
6059 !$OMP PRIVATE(J,IJ) &
6060 !$OMP REDUCTION(+:B) &
6061 !$OMP SCHEDULE(DYNAMIC,ichunk)
6062 DO i=1,n
6063 ij=globalrowoffsets(i+l)+l
6064 b(i)=globalmatd(ij+i)*x(i)
6065 DO j=1,i-1
6066 b(j)=b(j)+globalmatd(ij+j)*x(i)
6067 b(i)=b(i)+globalmatd(ij+j)*x(j)
6068 END DO
6069 END DO
6070 !$OMP END PARALLEL DO
6071 ELSE
6072 ! sparse, compressed matrix
6073 IF(sparsematrixoffsets(2,1) /= n) THEN
6074 CALL peend(24,'Aborted, vector/matrix size mismatch')
6075 stop 'AVPRD0: mismatched vector and matrix'
6076 END IF
6077 ! parallelize row (group) loop
6078 ! slot of 1024 'I' for next idle thread
6079 !$OMP PARALLEL DO &
6080 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
6081 !$OMP PRIVATE(IA,IB,IN,JA,JB) &
6082 !$OMP REDUCTION(+:B) &
6083 !$OMP SCHEDULE(DYNAMIC,ichunk)
6084 DO ipg=1,napgrp
6085 iproc=0
6086 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
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 ! diagonal elements
6093 b(ia:ib)=globalmatd(ia:ib)*x(ia:ib)
6094 ! off-diagonals double precision
6095 ir=ipg
6096 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6097 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6098 ku=sparsematrixoffsets(1,ir+1)-kk
6099 indid=kk
6100 indij=ll
6101 IF (ku > 0) THEN
6102 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6103 DO i=ia,ib
6104 DO k=1,ku
6105 j=sparsematrixcolumns(indid+k)
6106 b(j)=b(j)+globalmatd(indij+k)*x(i)
6107 b(i)=b(i)+globalmatd(indij+k)*x(j)
6108 END DO
6109 indij=indij+ku
6110 END DO
6111 ELSE
6112 ! regions of continous column groups
6113 DO k=2,ku-2,2
6114 j=sparsematrixcolumns(indid+k) ! first group
6115 ja=globalallindexgroups(j) ! first (global) column
6116 lj=sparsematrixcolumns(indid+k-1) ! region offset
6117 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6118 jb=ja+jn-1 ! last (global) column
6119 lj=1 ! index (in group region)
6120 DO i=ia,ib
6121 b(i)=b(i)+dot_product(globalmatd(indij+lj:indij+lj+jn-1),x(ja:jb))
6122 lj=lj+jn
6123 END DO
6124 IF (mextnd == 0) THEN
6125 lj=1
6126 DO j=ja,jb
6127 b(j)=b(j)+dot_product(globalmatd(indij+lj:indij+jn*in:jn),x(ia:ib))
6128 lj=lj+1
6129 END DO
6130 END IF
6131 indij=indij+in*jn
6132 END DO
6133 END IF
6134 END IF
6135 ! mixed precision
6136 IF (nspc > 1) THEN
6137 ir=ipg+napgrp+1 ! off-diagonals single precision
6138 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6139 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6140 ku=sparsematrixoffsets(1,ir+1)-kk
6141 indid=kk
6142 indij=ll
6143 IF (ku == 0) cycle
6144 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6145 DO i=ia,ib
6146 DO k=1,ku
6147 j=sparsematrixcolumns(indid+k)
6148 b(j)=b(j)+real(globalmatf(indij+k),mpd)*x(i)
6149 b(i)=b(i)+real(globalmatf(indij+k),mpd)*x(j)
6150 END DO
6151 indij=indij+ku
6152 END DO
6153 ELSE
6154 ! regions of continous column groups
6155 DO k=2,ku-2,2
6156 j=sparsematrixcolumns(indid+k) ! first group
6157 ja=globalallindexgroups(j) ! first (global) column
6158 lj=sparsematrixcolumns(indid+k-1) ! region offset
6159 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6160 jb=ja+jn-1 ! last (global) column
6161 lj=1 ! index (in group region)
6162 DO i=ia,ib
6163 b(i)=b(i)+dot_product(real(globalmatf(indij+lj:indij+lj+jn-1),mpd),x(ja:jb))
6164 lj=lj+jn
6165 END DO
6166 IF (mextnd == 0) THEN
6167 lj=1
6168 DO j=ja,jb
6169 b(j)=b(j)+dot_product(real(globalmatf(indij+lj:indij+jn*in:jn),mpd),x(ia:ib))
6170 lj=lj+1
6171 END DO
6172 END IF
6173 indij=indij+in*jn
6174 END DO
6175 END IF
6176 END IF
6177 END DO
6178 ENDIF
6179
6180END SUBROUTINE avprd0
6181
6182
6185SUBROUTINE anasps
6186 USE mpmod
6187
6188 IMPLICIT NONE
6189 INTEGER(mpi) :: ia
6190 INTEGER(mpi) :: ib
6191 INTEGER(mpi) :: ipg
6192 INTEGER(mpi) :: ir
6193 INTEGER(mpi) :: ispc
6194 INTEGER(mpi) :: lj
6195 REAL(mps) :: avg
6196
6197
6198 INTEGER(mpl) :: in
6199 INTEGER(mpl) :: jn
6200 INTEGER(mpl) :: k
6201 INTEGER(mpl) :: kk
6202 INTEGER(mpl) :: ku
6203 INTEGER(mpl) :: ll
6204 INTEGER(mpl) :: indid
6205 INTEGER(mpl), DIMENSION(12) :: icount
6206 SAVE
6207
6208 ! require sparse storage
6209 IF(matsto /= 2) RETURN
6210 ! reset
6211 icount=0
6212 icount(4)=huge(icount(4))
6213 icount(7)=huge(icount(7))
6214 icount(10)=huge(icount(10))
6215 ! loop over precisions
6216 DO ispc=1,nspc
6217 ! loop over row groups
6218 DO ipg=1,napgrp
6219 ! row group
6220 ia=globalallindexgroups(ipg) ! first (global) row
6221 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6222 in=ib-ia+1 ! number of rows
6223
6224 ir=ipg+(ispc-1)*(napgrp+1)
6225 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6226 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6227 ku=sparsematrixoffsets(1,ir+1)-kk
6228 indid=kk
6229 IF (ku == 0) cycle
6230 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6231 icount(1)=icount(1)+in
6232 icount(2)=icount(2)+in*ku
6233 ELSE
6234 ! regions of continous column groups
6235 DO k=2,ku-2,2
6236 lj=sparsematrixcolumns(indid+k-1) ! region offset
6237 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6238 icount(3)=icount(3)+1 ! block (region) counter
6239 icount(4)=min(icount(4),jn) ! min number of columns per block (region)
6240 icount(5)=icount(5)+jn ! sum number of columns per block (region)
6241 icount(6)=max(icount(6),jn) ! max number of columns per block (region)
6242 icount(7)=min(icount(7),in) ! min number of rows per block (region)
6243 icount(8)=icount(8)+in ! sum number of rows per block (region)
6244 icount(9)=max(icount(9),in) ! max number of rows per block (region)
6245 icount(10)=min(icount(10),in*jn) ! min number of elements per block (region)
6246 icount(11)=icount(11)+in*jn ! sum number of elements per block (region)
6247 icount(12)=max(icount(12),in*jn) ! max number of elements per block (region)
6248 END DO
6249 END IF
6250 END DO
6251 END DO
6252
6253 WRITE(*,*) "analysis of sparsity structure"
6254 IF (icount(1) > 0) THEN
6255 WRITE(*,101) "rows without compression/blocks ", icount(1)
6256 WRITE(*,101) " contained elements ", icount(2)
6257 ENDIF
6258 WRITE(*,101) "number of block matrices ", icount(3)
6259 avg=real(icount(5),mps)/real(icount(3),mps)
6260 WRITE(*,101) "number of columns (min,mean,max) ", icount(4), avg, icount(6)
6261 avg=real(icount(8),mps)/real(icount(3),mps)
6262 WRITE(*,101) "number of rows (min,mean,max) ", icount(7), avg, icount(9)
6263 avg=real(icount(11),mps)/real(icount(3),mps)
6264 WRITE(*,101) "number of elements (min,mean,max) ", icount(10), avg, icount(12)
6265101 FORMAT(2x,a34,i10,f10.3,i10)
6266
6267END SUBROUTINE anasps
6268
6278
6279SUBROUTINE avprod(n,x,b)
6280 USE mpmod
6281
6282 IMPLICIT NONE
6283
6284 INTEGER(mpi), INTENT(IN) :: n
6285 REAL(mpd), INTENT(IN) :: x(n)
6286 REAL(mpd), INTENT(OUT) :: b(n)
6287
6288 SAVE
6289 ! ...
6290 IF(n > nagb) THEN
6291 CALL peend(24,'Aborted, vector/matrix size mismatch')
6292 stop 'AVPROD: mismatched vector and matrix'
6293 END IF
6294 ! input to AVPRD0
6295 vecxav(1:n)=x
6296 vecxav(n+1:nagb)=0.0_mpd
6297 !use elimination for constraints ?
6298 IF(n < nagb) CALL qlmlq(vecxav,1,.false.) ! Q*x
6299 ! calclulate vecBav=globalMat*vecXav
6300 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
6301 !use elimination for constraints ?
6302 IF(n < nagb) CALL qlmlq(vecbav,1,.true.) ! Q^t*x
6303 ! output from AVPRD0
6304 b=vecbav(1:n)
6305
6306END SUBROUTINE avprod
6307
6308
6318
6319SUBROUTINE ijpgrp(itema,itemb,ij,lr,iprc)
6320 USE mpmod
6321
6322 IMPLICIT NONE
6323 INTEGER(mpi) :: ispc
6324 INTEGER(mpi) :: item1
6325 INTEGER(mpi) :: item2
6326 INTEGER(mpi) :: itemc
6327 INTEGER(mpi) :: jtem
6328 INTEGER(mpi) :: jtemn
6329 INTEGER(mpi) :: np
6330
6331 INTEGER(mpi), INTENT(IN) :: itema
6332 INTEGER(mpi), INTENT(IN) :: itemb
6333 INTEGER(mpl), INTENT(OUT) :: ij
6334 INTEGER(mpi), INTENT(OUT) :: lr
6335 INTEGER(mpi), INTENT(OUT) :: iprc
6336
6337 INTEGER(mpl) :: k
6338 INTEGER(mpl) :: kk
6339 INTEGER(mpl) :: kl
6340 INTEGER(mpl) :: ku
6341 INTEGER(mpl) :: ll
6342 ! ...
6343 ij=0
6344 lr=0
6345 iprc=0
6346 item1=max(itema,itemb) ! larger index
6347 item2=min(itema,itemb) ! smaller index
6348 IF(item2 <= 0.OR.item1 > napgrp) RETURN
6349 np=globalallindexgroups(item1+1)-globalallindexgroups(item1) ! size of group item1
6350 ! loop over precisions
6351 outer: DO ispc=1,nspc
6352 kk=sparsematrixoffsets(1,item1) ! offset (column lists)
6353 ll=sparsematrixoffsets(2,item1) ! offset (matrix)
6354 kl=1
6355 ku=sparsematrixoffsets(1,item1+1)-kk
6356 item1=item1+napgrp+1
6357 iprc=ispc
6358 IF (sparsematrixcolumns(kk+1) == 0) THEN ! compression ?
6359 ! compressed (list of continous regions of parameter groups (pairs of offset and 1. group index)
6360 kl=2
6361 ku=ku-2
6362 IF(ku < kl) cycle outer ! not found
6363 DO
6364 k=2*((kl+ku)/4) ! binary search
6365 jtem=sparsematrixcolumns(kk+k) ! first column (group) of region
6366 jtemn=sparsematrixcolumns(kk+k+2) ! first column (group) after region
6367 IF(item2 >= jtem.AND.item2 < jtemn) THEN
6368 ! length of region
6369 lr=sparsematrixcolumns(kk+k+1)-sparsematrixcolumns(kk+k-1)
6370 IF (globalallindexgroups(item2)-globalallindexgroups(jtem) >= lr) cycle outer ! outside region
6371 EXIT ! found
6372 END IF
6373 IF(item2 < jtem) THEN
6374 ku=k-2
6375 ELSE IF(item2 >= jtemn) THEN
6376 kl=k+2
6377 END IF
6378 IF(kl <= ku) cycle
6379 cycle outer ! not found
6380 END DO
6381 ! group offset in row
6382 ij=sparsematrixcolumns(kk+k-1)
6383 ! absolute offset
6384 ij=ll+ij*np+globalallindexgroups(item2)-globalallindexgroups(jtem)+1
6385
6386 ELSE
6387 ! simple column list
6388 itemc=globalallindexgroups(item2) ! first (col) index of group
6389 lr=int(ku,mpi) ! number of columns
6390 IF(ku < kl) cycle outer ! not found
6391 DO
6392 k=(kl+ku)/2 ! binary search
6393 jtem=sparsematrixcolumns(kk+k)
6394 IF(itemc == jtem) EXIT ! found
6395 IF(itemc < jtem) THEN
6396 ku=k-1
6397 ELSE IF(itemc > jtem) THEN
6398 kl=k+1
6399 END IF
6400 IF(kl <= ku) cycle
6401 cycle outer ! not found
6402 END DO
6403 ij=ll+k
6404
6405 END IF
6406 RETURN
6407 END DO outer
6408
6409END SUBROUTINE ijpgrp
6410
6416
6417FUNCTION ijprec(itema,itemb)
6418 USE mpmod
6419
6420 IMPLICIT NONE
6421
6422 INTEGER(mpi) :: lr
6423 INTEGER(mpl) :: ij
6424
6425 INTEGER(mpi), INTENT(IN) :: itema
6426 INTEGER(mpi), INTENT(IN) :: itemb
6427 INTEGER(mpi) :: ijprec
6428
6429 ! ...
6430 ijprec=1
6431 IF (matsto == 2.AND.nspc > 1) THEN ! sparse storage with mixed precision
6432 ! check groups
6433 CALL ijpgrp(itema,itemb,ij,lr,ijprec)
6434 END IF
6435
6436END FUNCTION ijprec
6437
6445
6446FUNCTION ijadd(itema,itemb) ! index using "d" and "z"
6447 USE mpmod
6448
6449 IMPLICIT NONE
6450
6451 INTEGER(mpi) :: item1
6452 INTEGER(mpi) :: item2
6453 INTEGER(mpi) :: ipg1
6454 INTEGER(mpi) :: ipg2
6455 INTEGER(mpi) :: lr
6456 INTEGER(mpi) :: iprc
6457
6458 INTEGER(mpi), INTENT(IN) :: itema
6459 INTEGER(mpi), INTENT(IN) :: itemb
6460
6461 INTEGER(mpl) :: ijadd
6462 INTEGER(mpl) :: ij
6463 ! ...
6464 ijadd=0
6465 item1=max(itema,itemb) ! larger index
6466 item2=min(itema,itemb) ! smaller index
6467 !print *, ' ijadd ', item1, item2
6468 IF(item2 <= 0.OR.item1 > nagb) RETURN
6469 IF(item1 == item2) THEN ! diagonal element
6470 ijadd=item1
6471 RETURN
6472 END IF
6473 ! ! off-diagonal element
6474 ! get parameter groups
6475 ipg1=globalallpartogroup(item1)
6476 ipg2=globalallpartogroup(item2)
6477 ! get offset for groups
6478 CALL ijpgrp(ipg1,ipg2,ij,lr,iprc)
6479 IF (ij == 0) RETURN
6480 ! add offset inside groups
6481 ijadd=ij+(item2-globalallindexgroups(ipg2))+(item1-globalallindexgroups(ipg1))*lr
6482 ! reduced precision?
6483 IF (iprc > 1) ijadd=-ijadd
6484
6485END FUNCTION ijadd
6486
6494
6495FUNCTION ijcsr3(itema,itemb) ! index using "d" and "z"
6496 USE mpmod
6497
6498 IMPLICIT NONE
6499
6500 INTEGER(mpi) :: item1
6501 INTEGER(mpi) :: item2
6502 INTEGER(mpi) :: jtem
6503
6504 INTEGER(mpi), INTENT(IN) :: itema
6505 INTEGER(mpi), INTENT(IN) :: itemb
6506
6507 INTEGER(mpl) :: ijcsr3
6508 INTEGER(mpl) :: kk
6509 INTEGER(mpl) :: ks
6510 INTEGER(mpl) :: ke
6511
6512 ! ...
6513 ijcsr3=0
6514 item1=max(itema,itemb) ! larger index
6515 item2=min(itema,itemb) ! smaller index
6516 !print *, ' ijadd ', item1, item2
6517 IF(item2 <= 0.OR.item1 > nagb) RETURN
6518 ! start of column list for row
6519 ks=csr3rowoffsets(item2)
6520 ! end of column list for row
6521 ke=csr3rowoffsets(item2+1)-1
6522 ! binary search
6523 IF(ke < ks) THEN
6524 ! empty list
6525 print *, ' IJCSR3 empty list ', item1, item2, ks, ke
6526 CALL peend(23,'Aborted, bad matrix index')
6527 stop 'ijcsr3: empty list'
6528 ENDIF
6529 DO
6530 kk=(ks+ke)/2 ! center of rgion
6531 jtem=int(csr3columnlist(kk),mpi)
6532 IF(item1 == jtem) EXIT ! found
6533 IF(item1 < jtem) THEN
6534 ke=kk-1
6535 ELSE
6536 ks=kk+1
6537 END IF
6538 IF(ks <= ke) cycle
6539 ! not found
6540 print *, ' IJCSR3 not found ', item1, item2, ks, ke
6541 CALL peend(23,'Aborted, bad matrix index')
6542 stop 'ijcsr3: not found'
6543 END DO
6544 ijcsr3=kk
6545END FUNCTION ijcsr3
6546
6552
6553FUNCTION matij(itema,itemb)
6554 USE mpmod
6555
6556 IMPLICIT NONE
6557
6558 INTEGER(mpi) :: item1
6559 INTEGER(mpi) :: item2
6560 INTEGER(mpl) :: i
6561 INTEGER(mpl) :: j
6562 INTEGER(mpl) :: ij
6563 INTEGER(mpl) :: ijadd
6564 INTEGER(mpl) :: ijcsr3
6565
6566 INTEGER(mpi), INTENT(IN) :: itema
6567 INTEGER(mpi), INTENT(IN) :: itemb
6568
6569 REAL(mpd) :: matij
6570 ! ...
6571 matij=0.0_mpd
6572 item1=max(itema,itemb) ! larger index
6573 item2=min(itema,itemb) ! smaller index
6574 IF(item2 <= 0.OR.item1 > nagb) RETURN
6575
6576 i=item1
6577 j=item2
6578
6579 IF(matsto < 2) THEN ! full or unpacked (block diagonal) symmetric matrix
6580 ij=globalrowoffsets(i)+j
6581 matij=globalmatd(ij)
6582 ELSE IF(matsto ==2) THEN ! sparse symmetric matrix (custom)
6583 ij=ijadd(item1,item2) ! inline code requires same time
6584 IF(ij > 0) THEN
6585 matij=globalmatd(ij)
6586 ELSE IF (ij < 0) THEN
6587 matij=real(globalmatf(-ij),mpd)
6588 END IF
6589 ELSE ! sparse symmetric matrix (CSR3)
6590 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
6591 ij=ijcsr3(item1,item2) ! inline code requires same time
6592 IF(ij > 0) matij=globalmatd(ij)
6593 ELSE ! sparse symmetric matrix (BSR3)
6594 ! block index
6595 ij=ijcsr3((item1-1)/matbsz+1,(item2-1)/matbsz+1)
6596 IF (ij > 0) THEN
6597 ! index of first element in block
6598 ij=(ij-1)*matbsz*matbsz+1
6599 ! adjust index for position in block
6600 ij=ij+mod(item1-1,matbsz)*matbsz+mod(item2-1,matbsz)
6601 matij=globalmatd(ij)
6602 ENDIF
6603 END IF
6604 END IF
6605
6606END FUNCTION matij
6607
6610
6611SUBROUTINE mhalf2
6612 USE mpmod
6613
6614 IMPLICIT NONE
6615 INTEGER(mpi) :: i
6616 INTEGER(mpi) :: ia
6617 INTEGER(mpi) :: ib
6618 INTEGER(mpi) :: ichunk
6619 INTEGER(mpi) :: in
6620 INTEGER(mpi) :: ipg
6621 INTEGER(mpi) :: ir
6622 INTEGER(mpi) :: ispc
6623 INTEGER(mpi) :: j
6624 INTEGER(mpi) :: ja
6625 INTEGER(mpi) :: jb
6626 INTEGER(mpi) :: jn
6627 INTEGER(mpi) :: lj
6628
6629 INTEGER(mpl) :: ij
6630 INTEGER(mpl) :: ijadd
6631 INTEGER(mpl) :: k
6632 INTEGER(mpl) :: kk
6633 INTEGER(mpl) :: ku
6634 INTEGER(mpl) :: ll
6635 ! ...
6636
6637 ichunk=min((napgrp+mthrd-1)/mthrd/8+1,1024)
6638
6639 DO ispc=1,nspc
6640 ! parallelize row loop
6641 ! slot of 1024 'I' for next idle thread
6642 !$OMP PARALLEL DO &
6643 !$OMP PRIVATE(I,IR,K,KK,LL,KU,IJ,J,LJ) &
6644 !$OMP PRIVATE(IA,IB,IN,JA,JB,JN) &
6645 !$OMP SCHEDULE(DYNAMIC,ichunk)
6646 DO ipg=1,napgrp
6647 ! row group
6648 ia=globalallindexgroups(ipg) ! first (global) row
6649 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6650 in=ib-ia+1 ! number of rows
6651 !
6652 ir=ipg+(ispc-1)*(napgrp+1)
6653 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6654 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6655 ku=sparsematrixoffsets(1,ir+1)-kk
6656 ! regions of continous column groups
6657 DO k=2,ku-2,2
6658 j=sparsematrixcolumns(kk+k) ! first group
6659 ja=globalallindexgroups(j) ! first (global) column
6660 lj=sparsematrixcolumns(kk+k-1) ! region offset
6661 jn=sparsematrixcolumns(kk+k+1)-lj ! number of columns
6662 jb=ja+jn-1 ! last (global) column
6663 ! skip first half
6664 IF (sparsematrixcolumns(kk+k+2) <= ipg) THEN
6665 ll=ll+in*jn
6666 cycle
6667 END IF
6668 ! at diagonal or in second half
6669 DO i=ia,ib ! loop over rows
6670 DO j=ja,jb ! loop over columns
6671 ll=ll+1
6672 IF (j > i) THEN
6673 ij=ijadd(i,j)
6674 IF (ispc==1) THEN
6675 globalmatd(ll)=globalmatd(ij)
6676 ELSE
6677 globalmatf(ll)=globalmatf(-ij)
6678 END IF
6679 END IF
6680 END DO
6681 END DO
6682 END DO
6683 END DO
6684 !$OMP END PARALLEL DO
6685 END DO
6686
6687END SUBROUTINE mhalf2
6688
6697
6698SUBROUTINE sechms(deltat,nhour,minut,secnd)
6699 USE mpdef
6700
6701 IMPLICIT NONE
6702 REAL(mps), INTENT(IN) :: deltat
6703 INTEGER(mpi), INTENT(OUT) :: minut
6704 INTEGER(mpi), INTENT(OUT):: nhour
6705 REAL(mps), INTENT(OUT):: secnd
6706 INTEGER(mpi) :: nsecd
6707 ! DELTAT = time in sec -> NHOUR,MINUT,SECND
6708 ! ...
6709 nsecd=nint(deltat,mpi) ! -> integer
6710 nhour=nsecd/3600
6711 minut=nsecd/60-60*nhour
6712 secnd=deltat-60*(minut+60*nhour)
6713END SUBROUTINE sechms
6714
6742
6743INTEGER(mpi) FUNCTION inone(item) ! translate 1-D identifier to nrs
6744 USE mpmod
6745 USE mpdalc
6746
6747 IMPLICIT NONE
6748 INTEGER(mpi), INTENT(IN) :: item
6749 INTEGER(mpi) :: j
6750 INTEGER(mpi) :: k
6751 INTEGER(mpi) :: iprime
6752 INTEGER(mpl) :: length
6753 INTEGER(mpl), PARAMETER :: four = 4
6754
6755 inone=0
6756 !print *, ' INONE ', item
6757 IF(item <= 0) RETURN
6758 IF(globalparheader(-1) == 0) THEN
6759 length=128 ! initial number
6760 CALL mpalloc(globalparlabelindex,four,length,'INONE: label & index')
6761 CALL mpalloc(globalparlabelcounter,length,'INONE: counter') ! updated in pargrp
6762 CALL mpalloc(globalparhashtable,2*length,'INONE: hash pointer')
6764 globalparheader(-0)=int(length,mpi) ! length of labels/indices
6765 globalparheader(-1)=0 ! number of stored items
6766 globalparheader(-2)=0 ! =0 during build-up
6767 globalparheader(-3)=int(length,mpi) ! next number
6768 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number
6769 globalparheader(-5)=0 ! number of overflows
6770 globalparheader(-6)=0 ! nr of variable parameters
6771 globalparheader(-8)=0 ! number of sorted items
6772 END IF
6773 outer: DO
6774 j=1+mod(item,globalparheader(-4))+globalparheader(-0)
6775 inner: DO ! normal case: find item
6776 k=j
6778 IF(j == 0) EXIT inner ! unused hash code
6779 IF(item == globalparlabelindex(1,j)) EXIT outer ! found
6780 END DO inner
6781 ! not found
6782 IF(globalparheader(-1) == globalparheader(-0).OR.globalparheader(-2) /= 0) THEN
6783 globalparheader(-5)=globalparheader(-5)+1 ! overflow
6784 j=0
6785 RETURN
6786 END IF
6787 globalparheader(-1)=globalparheader(-1)+1 ! increase number of elements
6789 j=globalparheader(-1)
6790 globalparhashtable(k)=j ! hash index
6791 globalparlabelindex(1,j)=item ! add new item
6792 globalparlabelindex(2,j)=0 ! reset index (for variable par.)
6793 globalparlabelindex(3,j)=0 ! reset group info (first label)
6794 globalparlabelindex(4,j)=0 ! reset group info (group index)
6795 globalparlabelcounter(j)=0 ! reset (long) counter
6796 IF(globalparheader(-1) /= globalparheader(-0)) EXIT outer
6797 ! update with larger dimension and redefine index
6799 CALL upone
6800 IF (lvllog > 1) WRITE(lunlog,*) 'INONE: array increased to', &
6801 globalparheader(-3),' words'
6802 END DO outer
6803
6804 ! counting now in pargrp
6805 !IF(globalParHeader(-2) == 0) THEN
6806 ! globalParLabelIndex(2,j)=globalParLabelIndex(2,j)+1 ! increase counter
6807 ! globalParHeader(-7)=globalParHeader(-7)+1
6808 !END IF
6809 inone=j
6810END FUNCTION inone
6811
6813SUBROUTINE upone
6814 USE mpmod
6815 USE mpdalc
6816
6817 IMPLICIT NONE
6818 INTEGER(mpi) :: i
6819 INTEGER(mpi) :: j
6820 INTEGER(mpi) :: k
6821 INTEGER(mpi) :: iprime
6822 INTEGER(mpi) :: nused
6823 LOGICAL :: finalUpdate
6824 INTEGER(mpl) :: oldLength
6825 INTEGER(mpl) :: newLength
6826 INTEGER(mpl), PARAMETER :: four = 4
6827 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArr
6828 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: tempVec
6829 SAVE
6830 ! ...
6831 finalupdate=(globalparheader(-3) == globalparheader(-1))
6832 IF(finalupdate) THEN ! final (cleanup) call
6833 IF (globalparheader(-1) > globalparheader(-8)) THEN
6836 END IF
6837 END IF
6838 ! save old LabelIndex
6839 nused = globalparheader(-1)
6840 oldlength = globalparheader(-0)
6841 CALL mpalloc(temparr,four,oldlength,'INONE: temp array')
6842 temparr(:,1:nused)=globalparlabelindex(:,1:nused)
6843 CALL mpalloc(tempvec,oldlength,'INONE: temp vector')
6844 tempvec(1:nused)=globalparlabelcounter(1:nused)
6848 ! create new LabelIndex
6849 newlength = globalparheader(-3)
6850 CALL mpalloc(globalparlabelindex,four,newlength,'INONE: label & index')
6851 CALL mpalloc(globalparlabelcounter,newlength,'INONE: counter')
6852 CALL mpalloc(globalparhashtable,2*newlength,'INONE: hash pointer')
6854 globalparlabelindex(:,1:nused) = temparr(:,1:nused) ! copy back saved content
6855 globalparlabelcounter(1:nused) = tempvec(1:nused) ! copy back saved content
6856 CALL mpdealloc(tempvec)
6857 CALL mpdealloc(temparr)
6858 globalparheader(-0)=int(newlength,mpi) ! length of labels/indices
6860 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number < LNDA
6861 ! redefine hash
6862 outer: DO i=1,globalparheader(-1)
6864 inner: DO
6865 k=j
6867 IF(j == 0) EXIT inner ! unused hash code
6868 IF(j == i) cycle outer ! found
6869 ENDDO inner
6871 END DO outer
6872 IF(.NOT.finalupdate) RETURN
6873
6874 globalparheader(-2)=1 ! set flag to inhibit further updates
6875 IF (lvllog > 1) THEN
6876 WRITE(lunlog,*) ' '
6877 WRITE(lunlog,*) 'INONE: array reduced to',newlength,' words'
6878 WRITE(lunlog,*) 'INONE:',globalparheader(-1),' items stored.'
6879 END IF
6880END SUBROUTINE upone ! update, redefine
6881
6883SUBROUTINE useone
6884 USE mpmod
6885
6886 IMPLICIT NONE
6887 INTEGER(mpi) :: i
6888 INTEGER(mpi) :: j
6889 INTEGER(mpi) :: k
6890 SAVE
6891 ! ...
6892 IF (globalparheader(-1) > globalparheader(-8)) THEN
6894 ! redefine hash
6896 outer: DO i=1,globalparheader(-1)
6898 inner: DO
6899 k=j
6901 IF(j == 0) EXIT inner ! unused hash code
6902 IF(j == i) cycle outer ! found
6903 ENDDO inner
6905 END DO outer
6907 END IF
6908END SUBROUTINE useone ! make usable
6909
6914
6915INTEGER(mpi) FUNCTION iprime(n)
6916 USE mpdef
6917
6918 IMPLICIT NONE
6919 INTEGER(mpi), INTENT(IN) :: n
6920 INTEGER(mpi) :: nprime
6921 INTEGER(mpi) :: nsqrt
6922 INTEGER(mpi) :: i
6923 ! ...
6924 SAVE
6925 nprime=n ! max number
6926 IF(mod(nprime,2) == 0) nprime=nprime+1 ! ... odd number
6927 outer: DO
6928 nprime=nprime-2 ! next lower odd number
6929 nsqrt=int(sqrt(real(nprime,mps)),mpi)
6930 DO i=3,nsqrt,2 !
6931 IF(i*(nprime/i) == nprime) cycle outer ! test prime number
6932 END DO
6933 EXIT outer ! found
6934 END DO outer
6935 iprime=nprime
6936END FUNCTION iprime
6937
6947SUBROUTINE loop1
6948 USE mpmod
6949 USE mpdalc
6950
6951 IMPLICIT NONE
6952 INTEGER(mpi) :: i
6953 INTEGER(mpi) :: idum
6954 INTEGER(mpi) :: in
6955 INTEGER(mpi) :: indab
6956 INTEGER(mpi) :: itgbi
6957 INTEGER(mpi) :: itgbl
6958 INTEGER(mpi) :: ivgbi
6959 INTEGER(mpi) :: j
6960 INTEGER(mpi) :: jgrp
6961 INTEGER(mpi) :: lgrp
6962 INTEGER(mpi) :: mqi
6963 INTEGER(mpi) :: nc31
6964 INTEGER(mpi) :: nr
6965 INTEGER(mpi) :: nwrd
6966 INTEGER(mpi) :: inone
6967 REAL(mpd) :: param
6968 REAL(mpd) :: presg
6969 REAL(mpd) :: prewt
6970
6971 INTEGER(mpl) :: length
6972 INTEGER(mpl) :: rows
6973 SAVE
6974 ! ...
6975 WRITE(lunlog,*) ' '
6976 WRITE(lunlog,*) 'LOOP1: starting'
6977 CALL mstart('LOOP1')
6978
6979 ! add labels from parameter, constraints, measurements, comments -------------
6980 DO i=1, lenparameters
6981 idum=inone(listparameters(i)%label)
6982 END DO
6983 DO i=1, lenpresigmas
6984 idum=inone(listpresigmas(i)%label)
6985 END DO
6986 DO i=1, lenconstraints
6987 idum=inone(listconstraints(i)%label)
6988 END DO
6989 DO i=1, lenmeasurements
6990 idum=inone(listmeasurements(i)%label)
6991 END DO
6992 DO i=1, lencomments
6993 idum=inone(listcomments(i)%label)
6994 END DO
6995
6996 IF(globalparheader(-1) /= 0) THEN
6997 WRITE(lunlog,*) 'LOOP1:',globalparheader(-1), ' labels from txt data stored'
6998 END IF
6999 WRITE(lunlog,*) 'LOOP1: reading data files'
7000
7001 neqn=0 ! number of equations
7002 negb=0 ! number of equations with global parameters
7003 ndgb=0 ! number of global derivatives
7004 nzgb=0 ! number of zero global derivatives
7005 DO
7006 DO j=1,globalparheader(-1)
7007 globalparlabelindex(2,j)=0 ! reset count
7008 END DO
7009
7010 CALL hmpldf(1,'Number of words/record in binary file')
7011 CALL hmpdef(8,0.0,60.0,'not_stored data per record')
7012 ! define read buffer
7013 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7014 nwrd=nc31+1
7015 IF(ndimbuf > nwrd) THEN
7016 CALL peend(20,'Aborted, bad binary records')
7017 stop 'LOOP1: length of binary record exceeds cache size, wrong file type?'
7018 END IF
7019 length=nwrd*mthrdr
7020 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7021 nwrd=nc31*10+2+ndimbuf
7022 length=nwrd*mthrdr
7023 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7024 CALL mpalloc(readbufferdatad,length,'read buffer, double')
7025 ! to read (old) float binary files
7026 length=(ndimbuf+2)*mthrdr
7027 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7028
7029 ! read all data files and add all labels to global labels table ----
7030 IF(mprint /= 0) THEN
7031 WRITE(*,*) 'Read all binary data files:'
7032 END IF
7033
7034 DO
7035 CALL peread(nr) ! read records
7036 IF (skippedrecords == 0) THEN
7037 CALL peprep(0) ! prepare records
7038 CALL pepgrp ! update parameter group info
7039 END IF
7040 IF(nr <= 0) EXIT ! end of data?
7041 END DO
7042 ! release read buffer
7047 IF (skippedrecords == 0) THEN
7048 EXIT
7049 ELSE
7050 WRITE(lunlog,*) 'LOOP1: reading data files again'
7051 END IF
7052 END DO
7053
7054 IF(nhistp /= 0) THEN
7055 CALL hmprnt(1)
7056 CALL hmprnt(8)
7057 END IF
7058 CALL hmpwrt(1)
7059 CALL hmpwrt(8)
7060 ntgb = globalparheader(-1) ! total number of labels/parameters
7061 IF (ntgb == 0) THEN
7062 CALL peend(21,'Aborted, no labels/parameters defined')
7063 stop 'LOOP1: no labels/parameters defined'
7064 END IF
7065 CALL upone ! finalize the global label table
7066
7067 WRITE(lunlog,*) 'LOOP1:',ntgb, &
7068 ' is total number NTGB of labels/parameters'
7069 ! histogram number of entries per label ----------------------------
7070 CALL hmpldf(2,'Number of entries per label')
7071 DO j=1,ntgb
7072 CALL hmplnt(2,globalparlabelindex(2,j))
7073 END DO
7074 IF(nhistp /= 0) CALL hmprnt(2) ! print histogram
7075 CALL hmpwrt(2) ! write to his file
7076
7077 ! three subarrays for all global parameters ------------------------
7078 length=ntgb
7079 CALL mpalloc(globalparameter,length,'global parameters')
7080 globalparameter=0.0_mpd
7081 CALL mpalloc(globalparpresigma,length,'pre-sigmas') ! presigmas
7083 CALL mpalloc(globalparstart,length,'global parameters at start')
7085 CALL mpalloc(globalparcopy,length,'copy of global parameters')
7086 CALL mpalloc(globalparcons,length,'global parameter constraints')
7088 CALL mpalloc(globalparcomments,length,'global parameter comments')
7090
7091 DO i=1,lenparameters ! parameter start values
7092 param=listparameters(i)%value
7093 in=inone(listparameters(i)%label)
7094 IF(in /= 0) THEN
7095 globalparameter(in)=param
7096 globalparstart(in)=param
7097 ENDIF
7098 END DO
7099
7100 DO i=1, lencomments
7101 in=inone(listcomments(i)%label)
7102 IF(in /= 0) globalparcomments(in)=i
7103 END DO
7104
7105 npresg=0
7106 DO i=1,lenpresigmas ! pre-sigma values
7107 presg=listpresigmas(i)%value
7108 in=inone(listpresigmas(i)%label)
7109 IF(in /= 0) THEN
7110 IF(presg > 0.0) npresg=npresg+1 ! FIXME: check if enough 'entries'?
7111 globalparpresigma(in)=presg ! insert pre-sigma 0 or > 0
7112 END IF
7113 END DO
7114 WRITE(lunlog,*) 'LOOP1:',npresg,' is number of pre-sigmas'
7115 WRITE(*,*) 'LOOP1:',npresg,' is number of pre-sigmas'
7116 IF(npresg == 0) WRITE(*,*) 'Warning: no pre-sigmas defined'
7117
7118 ! build constraint groups, check for redundancy constrints
7119 CALL grpcon
7120
7121 ! determine flag variable (active) or fixed (inactive) -------------
7122
7123 indab=0
7124 DO i=1,ntgb
7125 IF (globalparpresigma(i) < 0.0) THEN
7126 globalparlabelindex(2,i)=-1 ! fixed (pre-sigma), not used in matrix (not active)
7127 ELSE IF(globalparlabelcounter(i) < mreqenf) THEN
7128 globalparlabelindex(2,i)=-2 ! fixed (entries cut), not used in matrix (not active)
7129 ELSE IF (globalparcons(i) < 0) THEN
7130 globalparlabelindex(2,i)=-4 ! fixed (redundant), not used in matrix (not active)
7131 ELSE
7132 indab=indab+1
7133 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
7134 END IF
7135 END DO
7136 globalparheader(-6)=indab ! counted variable
7137 nvgb=indab ! nr of variable parameters
7138 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7139 IF(iteren > mreqenf) THEN
7140 IF (mcount == 0) THEN
7141 CALL loop1i ! iterate entries cut
7142 ELSE
7143 WRITE(lunlog,*) 'LOOP1: counting records, NO iteration of entries cut !'
7144 iteren=0
7145 END IF
7146 END IF
7147
7148 ! --- check for parameter groups
7149 CALL hmpdef(15,0.0,120.0,'Number of parameters per group')
7150 ntpgrp=0
7151 DO j=1,ntgb
7152 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7153 ! new group?
7155 globalparlabelindex(4,j)=ntpgrp ! relation total index -> group
7156 END DO
7157 ! check variable parameters
7158 nvpgrp=0
7159 lgrp=-1
7160 DO j=1,ntgb
7161 IF (globalparlabelindex(2,j) <= 0) cycle ! skip fixed parameter
7162 ! new group ?
7163 IF (globalparlabelindex(4,j) /= lgrp) nvpgrp=nvpgrp+1
7164 lgrp=globalparlabelindex(4,j)
7165 END DO
7166 length=ntpgrp; rows=2
7167 CALL mpalloc(globaltotindexgroups,rows,length,'parameter groups, 1. index and size')
7169 ! fill
7170 lgrp=-1
7171 DO j=1,ntgb
7172 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7173 jgrp=globalparlabelindex(4,j)
7174 IF (jgrp /= lgrp) globaltotindexgroups(1,jgrp)=j ! first (total) index
7175 globaltotindexgroups(2,jgrp)=globaltotindexgroups(2,jgrp)+1 ! (total) size
7176 lgrp=jgrp
7177 END DO
7178 DO j=1,ntpgrp
7179 CALL hmpent(15,real(globaltotindexgroups(2,j),mps))
7180 END DO
7181 IF(nhistp /= 0) CALL hmprnt(15) ! print histogram
7182 CALL hmpwrt(15) ! write to his file
7183 WRITE(lunlog,*) 'LOOP1:',ntpgrp, &
7184 ' is total number NTPGRP of label/parameter groups'
7185 !print *, ' globalTotIndexGroups ', globalTotIndexGroups
7186
7187 ! translation table of length NVGB of total global indices ---------
7188 length=nvgb
7189 CALL mpalloc(globalparvartototal,length,'translation table var -> total')
7190 indab=0
7191 DO i=1,ntgb
7192 IF(globalparlabelindex(2,i) > 0) THEN
7193 indab=indab+1
7194 globalparvartototal(indab)=i
7195 END IF
7196 END DO
7197
7198 ! regularization ---------------------------------------------------
7199 CALL mpalloc(globalparpreweight,length,'pre-sigmas weights') ! presigma weights
7200 WRITE(*,112) ' Default pre-sigma =',regpre, &
7201 ' (if no individual pre-sigma defined)'
7202 WRITE(*,*) 'Pre-sigma factor is',regula
7203
7204 IF(nregul == 0) THEN
7205 WRITE(*,*) 'No regularization will be done'
7206 ELSE
7207 WRITE(*,*) 'Regularization will be done, using factor',regula
7208 END IF
7209112 FORMAT(a,e9.2,a)
7210 IF (nvgb <= 0) THEN
7211 CALL peend(22,'Aborted, no variable global parameters')
7212 stop '... no variable global parameters'
7213 ENDIF
7214
7215 DO ivgbi=1,nvgb ! IVGBI = index of variable global parameter
7216 itgbi=globalparvartototal(ivgbi) ! ITGBI = global parameter index
7217 presg=globalparpresigma(itgbi) ! get pre-sigma
7218 prewt=0.0 ! pre-weight
7219 IF(presg > 0.0) THEN
7220 prewt=1.0/presg**2 ! 1/presigma^2
7221 ELSE IF(presg == 0.0.AND.regpre > 0.0) THEN
7222 prewt=1.0/real(regpre**2,mpd) ! default 1/presigma^2
7223 END IF
7224 globalparpreweight(ivgbi)=regula*prewt ! weight = factor / presigma^2
7225 END DO
7226
7227 ! WRITE(*,*) 'GlPa_index GlPa_label array1 array6'
7228 DO i=1,ntgb
7229 itgbl=globalparlabelindex(1,i)
7230 ivgbi=globalparlabelindex(2,i)
7231 IF(ivgbi > 0) THEN
7232 ! WRITE(*,111) I,ITGBL,QM(IND1+I),QM(IND6+IVGBI)
7233 ELSE
7234 ! WRITE(*,111) I,ITGBL,QM(IND1+I)
7235 END IF
7236 END DO
7237 ! 111 FORMAT(I5,I10,F10.5,E12.4)
7238 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7239 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7240 ! To avoid INT(mpi) overflows in diagonalization
7241 IF (metsol == 2.AND.nvgb >= 46340) THEN
7242 metsol=1
7243 WRITE(*,101) 'Too many variable parameters for diagonalization, fallback is inversion'
7244 END IF
7245
7246 ! print overview over important numbers ----------------------------
7247
7248 nrecal=nrec
7249 IF(mprint /= 0) THEN
7250 WRITE(*,*) ' '
7251 WRITE(*,101) ' NREC',nrec,'number of records'
7252 IF (nrecd > 0) WRITE(*,101) ' NRECD',nrec,'number of records containing doubles'
7253 WRITE(*,101) ' NEQN',neqn,'number of equations (measurements)'
7254 WRITE(*,101) ' NEGB',negb,'number of equations with global parameters'
7255 WRITE(*,101) ' NDGB',ndgb,'number of global derivatives'
7256 IF (nzgb > 0) THEN
7257 WRITE(*,101) ' NZGB',nzgb,'number of zero global der. (ignored in entry counts)'
7258 ENDIF
7259 IF (mcount == 0) THEN
7260 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7261 ELSE
7262 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7263 ENDIF
7264 IF(iteren > mreqenf) &
7265 WRITE(*,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7266 WRITE(*,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7267 IF (mreqpe > 1) WRITE(*,101) &
7268 'MREQPE',mreqpe,'required number of pair entries'
7269 IF (msngpe >= 1) WRITE(*,101) &
7270 'MSNGPE',msngpe,'max pair entries single prec. storage'
7271 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7272 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7273 IF(mprint > 1) THEN
7274 WRITE(*,*) ' '
7275 WRITE(*,*) 'Global parameter labels:'
7276 mqi=ntgb
7277 IF(mqi <= 100) THEN
7278 WRITE(*,*) (globalparlabelindex(2,i),i=1,mqi)
7279 ELSE
7280 WRITE(*,*) (globalparlabelindex(2,i),i=1,30)
7281 WRITE(*,*) ' ...'
7282 mqi=((mqi-20)/20)*20+1
7283 WRITE(*,*) (globalparlabelindex(2,i),i=mqi,ntgb)
7284 END IF
7285 END IF
7286 WRITE(*,*) ' '
7287 WRITE(*,*) ' '
7288 END IF
7289 WRITE(8,*) ' '
7290 WRITE(8,101) ' NREC',nrec,'number of records'
7291 IF (nrecd > 0) WRITE(8,101) ' NRECD',nrec,'number of records containing doubles'
7292 WRITE(8,101) ' NEQN',neqn,'number of equations (measurements)'
7293 WRITE(8,101) ' NEGB',negb,'number of equations with global parameters'
7294 WRITE(8,101) ' NDGB',ndgb,'number of global derivatives'
7295 IF (mcount == 0) THEN
7296 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7297 ELSE
7298 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7299 ENDIF
7300 IF(iteren > mreqenf) &
7301 WRITE(8,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7302 WRITE(8,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7303
7304 WRITE(lunlog,*) 'LOOP1: ending'
7305 WRITE(lunlog,*) ' '
7306 CALL mend
7307
7308101 FORMAT(1x,a8,' =',i14,' = ',a)
7309END SUBROUTINE loop1
7310
7318SUBROUTINE loop1i
7319 USE mpmod
7320 USE mpdalc
7321
7322 IMPLICIT NONE
7323 INTEGER(mpi) :: i
7324 INTEGER(mpi) :: ibuf
7325 INTEGER(mpi) :: ij
7326 INTEGER(mpi) :: indab
7327 INTEGER(mpi) :: ist
7328 INTEGER(mpi) :: j
7329 INTEGER(mpi) :: ja
7330 INTEGER(mpi) :: jb
7331 INTEGER(mpi) :: jsp
7332 INTEGER(mpi) :: nc31
7333 INTEGER(mpi) :: nr
7334 INTEGER(mpi) :: nlow
7335 INTEGER(mpi) :: nst
7336 INTEGER(mpi) :: nwrd
7337
7338 INTEGER(mpl) :: length
7339 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: newCounter
7340 SAVE
7341
7342 ! ...
7343 WRITE(lunlog,*) ' '
7344 WRITE(lunlog,*) 'LOOP1: iterating'
7345 WRITE(*,*) ' '
7346 WRITE(*,*) 'LOOP1: iterating'
7347
7348 length=ntgb
7349 CALL mpalloc(newcounter,length,'new entries counter')
7350 newcounter=0
7351
7352 ! define read buffer
7353 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7354 nwrd=nc31+1
7355 length=nwrd*mthrdr
7356 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7357 nwrd=nc31*10+2+ndimbuf
7358 length=nwrd*mthrdr
7359 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7360 CALL mpalloc(readbufferdatad,length,'read buffer, double')
7361 ! to read (old) float binary files
7362 length=(ndimbuf+2)*mthrdr
7363 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7364
7365 DO
7366 CALL peread(nr) ! read records
7367 CALL peprep(1) ! prepare records
7368 DO ibuf=1,numreadbuffer ! buffer for current record
7369 ist=readbufferpointer(ibuf)+1
7371 nwrd=nst-ist+1
7372 DO ! loop over measurements
7373 CALL isjajb(nst,ist,ja,jb,jsp)
7374 IF(ja == 0.AND.jb == 0) EXIT
7375 IF(ja /= 0) THEN
7376 nlow=0
7377 DO j=1,ist-jb
7378 ij=readbufferdatai(jb+j) ! index of global parameter
7379 ij=globalparlabelindex(2,ij) ! change to variable parameter
7380 IF(ij == -2) nlow=nlow+1 ! fixed by entries cut
7381 END DO
7382 IF(nlow == 0) THEN
7383 DO j=1,ist-jb
7384 ij=readbufferdatai(jb+j) ! index of global parameter
7385 newcounter(ij)=newcounter(ij)+1 ! count again
7386 END DO
7387 ENDIF
7388 END IF
7389 END DO
7390 ! end-of-event
7391 END DO
7392 IF(nr <= 0) EXIT ! end of data?
7393 END DO
7394
7395 ! release read buffer
7400
7401 indab=0
7402 DO i=1,ntgb
7403 IF(globalparlabelindex(2,i) > 0) THEN
7404 IF(newcounter(i) >= mreqenf .OR. globalparlabelcounter(i) >= iteren) THEN
7405 indab=indab+1
7406 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
7407 ELSE
7408 globalparlabelindex(2,i)=-3 ! fixed (iterated entries cut), not used in matrix (not active)
7409 END IF
7410 END IF
7411 END DO
7412 globalparheader(-6)=indab ! counted variable
7413 nvgb=indab ! nr of variable parameters
7414 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7415 CALL mpdealloc(newcounter)
7416
7417END SUBROUTINE loop1i
7418
7429
7430SUBROUTINE loop2
7431 USE mpmod
7432 USE mpdalc
7433
7434 IMPLICIT NONE
7435 REAL(mps) :: chin2
7436 REAL(mps) :: chin3
7437 REAL(mps) :: cpr
7438 REAL(mps) :: fsum
7439 REAL(mps) :: gbc
7440 REAL(mps) :: gbu
7441 INTEGER(mpi) :: i
7442 INTEGER(mpi) :: ia
7443 INTEGER(mpi) :: ib
7444 INTEGER(mpi) :: ibuf
7445 INTEGER(mpi) :: icblst
7446 INTEGER(mpi) :: icboff
7447 INTEGER(mpi) :: icgb
7448 INTEGER(mpi) :: icgrp
7449 INTEGER(mpi) :: icount
7450 INTEGER(mpi) :: iext
7451 INTEGER(mpi) :: ihis
7452 INTEGER(mpi) :: ij
7453 INTEGER(mpi) :: ij1
7454 INTEGER(mpi) :: ijn
7455 INTEGER(mpi) :: ioff
7456 INTEGER(mpi) :: ipoff
7457 INTEGER(mpi) :: iproc
7458 INTEGER(mpi) :: irecmm
7459 INTEGER(mpi) :: ist
7460 INTEGER(mpi) :: itgbi
7461 INTEGER(mpi) :: itgbij
7462 INTEGER(mpi) :: itgbik
7463 INTEGER(mpi) :: ivgbij
7464 INTEGER(mpi) :: ivgbik
7465 INTEGER(mpi) :: ivpgrp
7466 INTEGER(mpi) :: j
7467 INTEGER(mpi) :: ja
7468 INTEGER(mpi) :: jb
7469 INTEGER(mpi) :: jcgrp
7470 INTEGER(mpi) :: jext
7471 INTEGER(mpi) :: jcgb
7472 INTEGER(mpi) :: jrec
7473 INTEGER(mpi) :: jsp
7474 INTEGER(mpi) :: joff
7475 INTEGER(mpi) :: k
7476 INTEGER(mpi) :: kcgrp
7477 INTEGER(mpi) :: kfile
7478 INTEGER(mpi) :: l
7479 INTEGER(mpi) :: label
7480 INTEGER(mpi) :: labelf
7481 INTEGER(mpi) :: labell
7482 INTEGER(mpi) :: lvpgrp
7483 INTEGER(mpi) :: lu
7484 INTEGER(mpi) :: lun
7485 INTEGER(mpi) :: maeqnf
7486 INTEGER(mpi) :: nall
7487 INTEGER(mpi) :: naeqna
7488 INTEGER(mpi) :: naeqnf
7489 INTEGER(mpi) :: naeqng
7490 INTEGER(mpi) :: npdblk
7491 INTEGER(mpi) :: nc31
7492 INTEGER(mpi) :: ncachd
7493 INTEGER(mpi) :: ncachi
7494 INTEGER(mpi) :: ncachr
7495 INTEGER(mpi) :: ncon
7496 INTEGER(mpi) :: nda
7497 INTEGER(mpi) :: ndf
7498 INTEGER(mpi) :: ndfmax
7499 INTEGER(mpi) :: nfixed
7500 INTEGER(mpi) :: nggd
7501 INTEGER(mpi) :: nggi
7502 INTEGER(mpi) :: nmatmo
7503 INTEGER(mpi) :: noff
7504 INTEGER(mpi) :: npair
7505 INTEGER(mpi) :: npar
7506 INTEGER(mpi) :: nparmx
7507 INTEGER(mpi) :: nr
7508 INTEGER(mpi) :: nrece
7509 INTEGER(mpi) :: nrecf
7510 INTEGER(mpi) :: nrecmm
7511 INTEGER(mpi) :: nst
7512 INTEGER(mpi) :: nwrd
7513 INTEGER(mpi) :: inone
7514 INTEGER(mpi) :: inc
7515 REAL(mps) :: wgh
7516 REAL(mps) :: wolfc3
7517 REAL(mps) :: wrec
7518 REAL(mps) :: chindl
7519
7520 REAL(mpd)::dstat(3)
7521 REAL(mpd)::rerr
7522 INTEGER(mpl):: nblock
7523 INTEGER(mpl):: nbwrds
7524 INTEGER(mpl):: noff8
7525 INTEGER(mpl):: ndimbi
7526 INTEGER(mpl):: ndimsa(4)
7527 INTEGER(mpl):: ndgn
7528 INTEGER(mpl):: nnzero
7529 INTEGER(mpl):: matsiz(2)
7530 INTEGER(mpl):: matwords
7531 INTEGER(mpl):: mbwrds
7532 INTEGER(mpl):: length
7533 INTEGER(mpl):: rows
7534 INTEGER(mpl):: cols
7535 INTEGER(mpl), PARAMETER :: two=2
7536 INTEGER(mpi) :: maxGlobalPar = 0
7537 INTEGER(mpi) :: maxLocalPar = 0
7538 INTEGER(mpi) :: maxEquations = 0
7539
7540 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupList
7541 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupIndex
7542 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
7543 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecBlockCounts
7544
7545 INTERFACE ! needed for assumed-shape dummy arguments
7546 SUBROUTINE ndbits(npgrp,ndims,nsparr,ihst)
7547 USE mpdef
7548 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7549 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7550 INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr
7551 INTEGER(mpi), INTENT(IN) :: ihst
7552 END SUBROUTINE ndbits
7553 SUBROUTINE ckbits(npgrp,ndims)
7554 USE mpdef
7555 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7556 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7557 END SUBROUTINE ckbits
7558 SUBROUTINE spbits(npgrp,nsparr,nsparc)
7559 USE mpdef
7560 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7561 INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr
7562 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc
7563 END SUBROUTINE spbits
7564 SUBROUTINE gpbmap(ngroup,npgrp,npair)
7565 USE mpdef
7566 INTEGER(mpi), INTENT(IN) :: ngroup
7567 INTEGER(mpi), DIMENSION(:,:), INTENT(IN) :: npgrp
7568 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair
7569 END SUBROUTINE gpbmap
7570 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
7571 USE mpdef
7572 INTEGER(mpi), INTENT(IN) :: ipgrp
7573 INTEGER(mpi), INTENT(OUT) :: npair
7574 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
7575 END SUBROUTINE ggbmap
7576 SUBROUTINE pbsbits(npgrp,ibsize,nnzero,nblock,nbkrow)
7577 USE mpdef
7578 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7579 INTEGER(mpi), INTENT(IN) :: ibsize
7580 INTEGER(mpl), INTENT(OUT) :: nnzero
7581 INTEGER(mpl), INTENT(OUT) :: nblock
7582 INTEGER(mpi), DIMENSION(:),INTENT(OUT) :: nbkrow
7583 END SUBROUTINE pbsbits
7584 SUBROUTINE pblbits(npgrp,ibsize,nsparr,nsparc)
7585 USE mpdef
7586 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7587 INTEGER(mpi), INTENT(IN) :: ibsize
7588 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7589 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7590 END SUBROUTINE pblbits
7591 SUBROUTINE prbits(npgrp,nsparr)
7592 USE mpdef
7593 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7594 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparr
7595 END SUBROUTINE prbits
7596 SUBROUTINE pcbits(npgrp,nsparr,nsparc)
7597 USE mpdef
7598 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7599 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7600 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7601 END SUBROUTINE pcbits
7602 END INTERFACE
7603
7604 SAVE
7605
7606 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
7607
7608 ! ...
7609 WRITE(lunlog,*) ' '
7610 WRITE(lunlog,*) 'LOOP2: starting'
7611 CALL mstart('LOOP2')
7612
7613 ! two subarrays to get the global parameter indices, used in an event
7614 length=nvgb
7615 CALL mpalloc(globalindexusage,length,'global index')
7616 CALL mpalloc(backindexusage,length,'back index')
7618 CALL mpalloc(globalindexranges,length,'global index ranges')
7620
7621 length=ntgb
7622 CALL mpalloc(globalparlabelzeros,length,'global label with zero der. counters')
7624
7625 ! prepare constraints - determine number of constraints NCGB
7626 ! - sort and split into blocks
7627 ! - update globalIndexRanges
7628 CALL prpcon
7629
7630 IF (metsol == 3.AND.icelim <= 0) THEN
7631 ! decomposition: enforce elimination
7632 icelim=1
7633 WRITE(lunlog,*) ' Elimination for constraints enforced for solution by decomposition!'
7634 END IF
7635 IF (metsol == 9.AND.icelim > 0) THEN
7636 ! sparsePARDISO: enforce multipliers
7637 icelim=0
7638 WRITE(lunlog,*) ' Lagrange multipliers enforced for solution by sparsePARDISO!'
7639 END IF
7640 IF (matsto > 0.AND.icelim > 1) THEN
7641 ! decomposition: enforce elimination
7642 icelim=1
7643 WRITE(lunlog,*) ' Elimination for constraints with mpqldec enforced (LAPACK only for unpacked storage)!'
7644 END IF
7645 IF (icelim > 0) THEN ! elimination
7646 nagb=nvgb ! total number of parameters
7647 napgrp=nvpgrp ! total number of parameter groups
7648 nfgb=nvgb-ncgb ! number of fit parameters
7649 nprecond(1)=0 ! number of constraints for preconditioner
7650 nprecond(2)=nfgb ! matrix size for preconditioner
7651 nprecond(3)=0 ! number of constraint blocks for preconditioner
7652 ELSE ! Lagrange multipliers
7653 nagb=nvgb+ncgb ! total number of parameters
7654 napgrp=nvpgrp+ncgb ! total number of parameter groups
7655 nfgb=nagb ! number of fit parameters
7656 nprecond(1)=ncgb ! number of constraints for preconditioner
7657 nprecond(2)=nvgb ! matrix size for preconditioner
7658 nprecond(3)=ncblck ! number of constraint blocks for preconditioner
7659 ENDIF
7660 noff8=int(nagb,mpl)*int(nagb-1,mpl)/2
7661
7662 ! all (variable) parameter groups
7663 length=napgrp+1
7664 CALL mpalloc(globalallindexgroups,length,'all parameter groups, 1. index')
7666 ivpgrp=0
7667 lvpgrp=-1
7668 DO i=1,ntgb
7669 ij=globalparlabelindex(2,i)
7670 IF (ij <= 0) cycle ! variable ?
7671 IF (globalparlabelindex(4,i) /= lvpgrp) THEN
7672 ivpgrp=ivpgrp+1
7673 globalallindexgroups(ivpgrp)=ij ! first index
7674 lvpgrp=globalparlabelindex(4,i)
7675 END IF
7676 END DO
7677 ! Lagrange multipliers
7678 IF (napgrp > nvpgrp) THEN
7679 DO jcgb=1, ncgb
7680 ivpgrp=ivpgrp+1
7681 globalallindexgroups(ivpgrp)=nvgb+jcgb
7682 END DO
7683 END IF
7685 ! from all (variable) parameters to group
7686 length=nagb
7687 CALL mpalloc(globalallpartogroup,length,'translation table all (var) par -> group')
7689 DO i=1,napgrp
7692 END DO
7693 END DO
7694 IF (icheck > 2) THEN
7695 print *
7696 print *, ' Variable parameter groups ', nvpgrp
7697 DO i=1,nvpgrp
7699 k=globalparlabelindex(4,itgbi) ! (total) group index
7701 globalparlabelindex(1,itgbi)
7702 END DO
7703 print *
7704 END IF
7705
7706 ! read all data files and add all variable index pairs -------------
7707
7708 IF (icheck > 1) CALL clbmap(ntpgrp+ncgrp)
7709
7710 IF(matsto == 2) THEN
7711 ! MINRES, sparse storage
7712 CALL clbits(napgrp,mreqpe,mhispe,msngpe,mextnd,ndimbi,nspc) ! get dimension for bit storage, encoding, precision info
7713 END IF
7714 IF(matsto == 3) THEN
7715 ! PARDISO, upper triangle (parameter groups) incl. rectangular part (constraints)
7716 CALL plbits(nvpgrp,nvgb,ncgb,ndimbi) ! get dimension for bit storage, global parameters and constraints
7717 END IF
7718
7719 IF (imonit /= 0) THEN
7720 length=ntgb
7721 CALL mpalloc(measindex,length,'measurement counter/index')
7722 measindex=0
7723 CALL mpalloc(measres,length,'measurement resolution')
7724 measres=0.0_mps
7725 lunmon=9
7726 CALL mvopen(lunmon,'millepede.mon')
7727 ENDIF
7728
7729 ! for checking appearance
7730 IF (icheck > 1) THEN
7731 length=5*(ntgb+ncgrp)
7732 CALL mpalloc(appearancecounter,length,'appearance statistics')
7734 length=ntgb
7735 CALL mpalloc(paircounter,length,'pair statistics')
7736 paircounter=0
7737 END IF
7738
7739 ! checking constraint goups
7740 IF (icheck > 0.AND. ncgrp > 0) THEN
7741 length=ncgrp
7742 CALL mpalloc(vecconsgroupcounts,length,'counter for constraint groups')
7744 CALL mpalloc(vecconsgrouplist,length,'constraint group list')
7745 CALL mpalloc(vecconsgroupindex,length,'constraint group index')
7746 vecconsgroupindex=0
7747 END IF
7748
7749 ! reading events===reading events===reading events===reading events=
7750 nrece =0 ! 'empty' records (no variable global parameters)
7751 nrecf =0 ! records with fixed global parameters
7752 naeqng=0 ! count number of equations (with global der.)
7753 naeqnf=0 ! count number of equations ( " , fixed)
7754 naeqna=0 ! all
7755 WRITE(lunlog,*) 'LOOP2: start event reading'
7756 ! monitoring for sparse matrix?
7757 irecmm=0
7758 IF (matsto == 2.AND.matmon /= 0) THEN
7759 nmatmo=0
7760 IF (matmon > 0) THEN
7761 nrecmm=matmon
7762 ELSE
7763 nrecmm=1
7764 END IF
7765 END IF
7766 DO k=1,3
7767 dstat(k)=0.0_mpd
7768 END DO
7769 ! define read buffer
7770 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7771 nwrd=nc31+1
7772 length=nwrd*mthrdr
7773 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7774 nwrd=nc31*10+2+ndimbuf
7775 length=nwrd*mthrdr
7776 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7777 CALL mpalloc(readbufferdatad,length,'read buffer, real')
7778 ! to read (old) float binary files
7779 length=(ndimbuf+2)*mthrdr
7780 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7781
7782 DO
7783 CALL peread(nr) ! read records
7784 CALL peprep(1) ! prepare records
7785 ioff=0
7786 DO ibuf=1,numreadbuffer ! buffer for current record
7787 jrec=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
7788 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7789 nrec=ifd(kfile)+jrec ! global record number
7790 ! Printout for DEBUG
7791 IF(nrec <= mdebug) THEN
7792 nda=0
7793 wrec =real(readbufferdatad(readbufferpointer(ibuf)-1),mps) ! weight
7794 WRITE(*,*) ' '
7795 WRITE(*,*) 'Record number ',nrec,' from file ',kfile
7796 IF (wgh /= 1.0) WRITE(*,*) ' weight ',wrec
7797 ist=readbufferpointer(ibuf)+1
7799 DO ! loop over measurements
7800 CALL isjajb(nst,ist,ja,jb,jsp)
7801 IF(ja == 0) EXIT
7802 nda=nda+1
7803 IF(nda > mdebg2) THEN
7804 IF(nda == mdebg2+1) WRITE(*,*) '... and more data'
7805 cycle
7806 END IF
7807 WRITE(*,*) ' '
7808 WRITE(*,*) nda, ' Measured value =',readbufferdatad(ja),' +- ',readbufferdatad(jb)
7809 WRITE(*,*) 'Local derivatives:'
7810 WRITE(*,107) (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
7811107 FORMAT(6(i3,g12.4))
7812 IF (jb < ist) THEN
7813 WRITE(*,*) 'Global derivatives:'
7814 WRITE(*,108) (globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
7815 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
7816108 FORMAT(3i11,g12.4)
7817 END IF
7818 IF(nda == 1) THEN
7819 WRITE(*,*) 'total_par_label __label__ var_par_index derivative'
7820 END IF
7821 END DO
7822 WRITE(*,*) ' '
7823 END IF
7824
7825 nagbn =0 ! count number of global derivatives
7826 nalcn =0 ! count number of local derivatives
7827 naeqn =0 ! count number of equations
7828 icgrp =0 ! count constraint groups
7829 maeqnf=naeqnf
7830 ist=readbufferpointer(ibuf)+1
7832 nwrd=nst-ist+1
7833 DO ! loop over measurements
7834 CALL isjajb(nst,ist,ja,jb,jsp)
7835 IF(ja == 0.AND.jb == 0) EXIT
7836 naeqn=naeqn+1
7837 naeqna=naeqna+1
7838 IF(ja /= 0) THEN
7839 IF (ist > jb) THEN
7840 naeqng=naeqng+1
7841 ! monitoring, group measurements, sum up entries and errors
7842 IF (imonit /= 0) THEN
7843 rerr =real(readbufferdatad(jb),mpd) ! the error
7844 ij=readbufferdatai(jb+1) ! index of first global parameter, used to group measurements
7845 measindex(ij)=measindex(ij)+1
7846 measres(ij)=measres(ij)+rerr
7847 END IF
7848 END IF
7849 nfixed=0
7850 DO j=1,ist-jb
7851 ij=readbufferdatai(jb+j) ! index of global parameter
7852 IF (nzgb > 0) THEN
7853 ! count zero global derivatives
7854 IF (readbufferdatad(jb+j) == 0.0_mpl) globalparlabelzeros(ij)=globalparlabelzeros(ij)+1
7855 END IF
7856 ! check appearance
7857 IF (icheck > 1) THEN
7858 joff = 5*(ij-1)
7859 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7860 IF (appearancecounter(joff+1) == 0) THEN
7861 appearancecounter(joff+1) = kfile
7862 appearancecounter(joff+2) = jrec ! (local) record number
7863 END IF
7864 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=appearancecounter(joff+5)+1
7865 appearancecounter(joff+3) = kfile
7866 appearancecounter(joff+4) = jrec ! (local) record number
7867 ! count pairs
7868 DO k=1,j
7870 END DO
7871 jcgrp=globalparcons(ij)
7872 ! correlate constraint groups with 'other' parameter groups
7873 DO k=1,j
7874 kcgrp=globalparcons(readbufferdatai(jb+k))
7875 IF (kcgrp == jcgrp) cycle
7876 IF (jcgrp > 0) CALL inbmap(ntpgrp+jcgrp,globalparlabelindex(4,readbufferdatai(jb+k)))
7877 IF (kcgrp > 0) CALL inbmap(ntpgrp+kcgrp,globalparlabelindex(4,ij))
7878 END DO
7879 END IF
7880 ! check constraint groups
7881 IF (icheck > 0.AND.ncgrp > 0) THEN
7882 k=globalparcons(ij) ! constraint group
7883 IF (k > 0) THEN
7884 icount=naeqn
7885 IF (mcount > 0) icount=1 ! count records
7886 IF (vecconsgroupindex(k) == 0) THEN
7887 ! add to list
7888 icgrp=icgrp+1
7889 vecconsgrouplist(icgrp)=k
7890 ! check appearance
7891 IF (icheck > 1) THEN
7892 joff = 5*(ntgb+k-1)
7893 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7894 IF (appearancecounter(joff+1) == 0) THEN
7895 appearancecounter(joff+1) = kfile
7896 appearancecounter(joff+2) = jrec ! (local) record number
7897 END IF
7898 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=&
7899 appearancecounter(joff+5)+1
7900 appearancecounter(joff+3) = kfile
7901 appearancecounter(joff+4) = jrec ! (local) record number
7902 END IF
7903 END IF
7904 IF (vecconsgroupindex(k) < icount) THEN
7905 ! count
7906 vecconsgroupindex(k)=icount
7908 END IF
7909 END IF
7910 END IF
7911
7912 ij=globalparlabelindex(2,ij) ! change to variable parameter
7913 IF(ij > 0) THEN
7914 ijn=backindexusage(ij) ! get index of index
7915 IF(ijn == 0) THEN ! not yet included
7916 nagbn=nagbn+1 ! count
7917 globalindexusage(nagbn)=ij ! store variable index
7918 backindexusage(ij)=nagbn ! store back index
7919 END IF
7920 ELSE
7921 nfixed=nfixed+1
7922 END IF
7923 END DO
7924 IF (nfixed > 0) naeqnf=naeqnf+1
7925 END IF
7926
7927 IF(ja /= 0.AND.jb /= 0) THEN
7928 DO j=1,jb-ja-1 ! local parameters
7929 ij=readbufferdatai(ja+j)
7930 nalcn=max(nalcn,ij)
7931 END DO
7932 END IF
7933 END DO
7934
7935 ! end-of-event
7936 IF (naeqnf > maeqnf) nrecf=nrecf+1
7937 irecmm=irecmm+1
7938 ! end-of-event-end-of-event-end-of-event-end-of-event-end-of-event-e
7939
7940 maxglobalpar=max(nagbn,maxglobalpar) ! maximum number of global parameters
7941 maxlocalpar=max(nalcn,maxlocalpar) ! maximum number of local parameters
7942 maxequations=max(naeqn,maxequations) ! maximum number of equations
7943
7944 ! sample statistics for caching
7945 dstat(1)=dstat(1)+real((nwrd+2)*2,mpd) ! record size
7946 dstat(2)=dstat(2)+real(nagbn+2,mpd) ! indices,
7947 dstat(3)=dstat(3)+real(nagbn*nagbn+nagbn,mpd) ! data for MUPDAT
7948
7949 ! clear constraint groups index
7950 DO k=1, icgrp
7951 vecconsgroupindex(vecconsgrouplist(k))=0
7952 END DO
7953
7954 CALL sort1k(globalindexusage,nagbn) ! sort global par.
7955
7956 IF (nagbn == 0) THEN
7957 nrece=nrece+1
7958 ELSE
7959 ! update parameter range
7962 ENDIF
7963
7964 ! overwrite read buffer with lists of global labels
7965 ioff=ioff+1
7966 readbufferpointer(ibuf)=ioff
7967 readbufferdatai(ioff)=ioff+nagbn
7968 joff=ioff
7969 lvpgrp=-1
7970 DO i=1,nagbn ! reset global index array, store parameter groups
7971 iext=globalindexusage(i)
7972 backindexusage(iext)=0
7973 ivpgrp=globalallpartogroup(iext)
7974 !ivpgrp=iext
7975 IF (ivpgrp /= lvpgrp) THEN
7976 joff=joff+1
7977 readbufferdatai(joff)=ivpgrp
7978 lvpgrp=ivpgrp
7979 END IF
7980 END DO
7981 readbufferdatai(ioff)=joff
7982 ioff=joff
7983
7984 END DO
7985 ioff=0
7986
7987 IF (matsto == 3) THEN
7988 !$OMP PARALLEL &
7989 !$OMP DEFAULT(PRIVATE) &
7990 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
7991 iproc=0
7992 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
7993 DO ibuf=1,numreadbuffer
7994 ist=readbufferpointer(ibuf)+1
7996 DO i=ist,nst ! store all combinations
7997 iext=readbufferdatai(i) ! variable global index
7998 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct column per thread
7999 DO l=i,nst
8000 jext=readbufferdatai(l)
8001 CALL inbits(iext,jext,1) ! save space
8002 END DO
8003 !$ ENDIF
8004 END DO
8005 END DO
8006 !$OMP END PARALLEL
8007 END IF
8008 IF (matsto == 2) THEN
8009 !$OMP PARALLEL &
8010 !$OMP DEFAULT(PRIVATE) &
8011 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
8012 iproc=0
8013 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
8014 DO ibuf=1,numreadbuffer
8015 ist=readbufferpointer(ibuf)+1
8017 DO i=ist,nst ! store all combinations
8018 iext=readbufferdatai(i) ! variable global index
8019 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct rows per thread
8020 DO l=ist,i
8021 jext=readbufferdatai(l)
8022 CALL inbits(iext,jext,1) ! save space
8023 END DO
8024 !$ ENDIF
8025 END DO
8026 END DO
8027 !$OMP END PARALLEL
8028 ! monitoring
8029 IF (matmon /= 0.AND. &
8030 (irecmm >= nrecmm.OR.irecmm == mxrec)) THEN
8031 IF (nmatmo == 0) THEN
8032 WRITE(*,*)
8033 WRITE(*,*) 'Monitoring of sparse matrix construction'
8034 WRITE(*,*) ' records ........ off-diagonal elements ', &
8035 '....... compression memory'
8036 WRITE(*,*) ' non-zero used(double) used', &
8037 '(float) [%] [GB]'
8038 END IF
8039 nmatmo=nmatmo+1
8040 CALL ckbits(globalallindexgroups,ndimsa)
8041 gbc=1.0e-9*real((mpi*ndimsa(2)+mpd*ndimsa(3)+mps*ndimsa(4))/mpi*(bit_size(1_mpi)/8),mps) ! GB compressed
8042 gbu=1.0e-9*real(((mpi+mpd)*(ndimsa(3)+ndimsa(4)))/mpi*(bit_size(1_mpi)/8),mps) ! GB uncompressed
8043 cpr=100.0*gbc/gbu
8044 WRITE(*,1177) irecmm,ndimsa(1),ndimsa(3),ndimsa(4),cpr,gbc
80451177 FORMAT(i9,3i13,f10.2,f11.6)
8046 DO WHILE(irecmm >= nrecmm)
8047 IF (matmon > 0) THEN
8048 nrecmm=nrecmm+matmon
8049 ELSE
8050 nrecmm=nrecmm*2
8051 END IF
8052 END DO
8053 END IF
8054
8055 END IF
8056
8057 IF (nr <= 0) EXIT ! next block of events ?
8058 END DO
8059 ! release read buffer
8064
8065 WRITE(lunlog,*) 'LOOP2: event reading ended - end of data'
8066 DO k=1,3
8067 dstat(k)=dstat(k)/real(nrec,mpd)
8068 END DO
8069 ! end=of=data=end=of=data=end=of=data=end=of=data=end=of=data=end=of
8070
8071 IF (icheck > 0.AND. ncgrp > 0) THEN
8072 CALL mpdealloc(vecconsgroupindex)
8073 CALL mpdealloc(vecconsgrouplist)
8074 END IF
8075
8076 IF (icheck > 1) THEN
8078 END IF
8079 IF (icheck > 3) THEN
8080 length=ntpgrp+ncgrp
8081 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
8082 print *
8083 print *, ' Total parameter groups pairs', ntpgrp
8084 DO i=1,ntpgrp
8085 itgbi=globaltotindexgroups(1,i)
8086 CALL ggbmap(i,npair,vecpairedpargroups)
8087 k=globalparlabelindex(4,itgbi) ! (total) group index
8088 print *, i, itgbi, globalparlabelindex(1,itgbi), npair, ':', vecpairedpargroups(:npair)
8089 END DO
8090 print *
8091 END IF
8092
8093 ! check constraints
8094 IF(matsto == 2) THEN
8095
8096 ! constraints and index pairs with Lagrange multiplier
8097 inc=max(mreqpe, msngpe+1) ! keep constraints in double precision
8098
8099 ! loop over (sorted) constraints
8100 DO jcgb=1,ncgb
8101 icgb=matconssort(3,jcgb) ! unsorted constraint index
8102 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
8103 label=listconstraints(i)%label
8104 itgbi=inone(label)
8105 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
8106 IF(ij > 0 .AND. nagb > nvgb) THEN
8108 END IF
8109 END DO
8110 END DO
8111 END IF
8112 IF(matsto == 3) THEN
8113 ! loop over (sorted) constraints
8114 DO jcgb=1,ncgb
8115 icgb=matconssort(3,jcgb) ! unsorted constraint index
8116 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
8117 label=listconstraints(i)%label
8118 itgbi=inone(label)
8119 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
8120 IF(ij > 0.AND.listconstraints(i)%value /= 0.0_mpd) THEN
8121 ! non-zero coefficient
8122 CALL irbits(ij,jcgb)
8123 END IF
8124 END DO
8125 END DO
8126 END IF
8127
8128 ! check measurements
8129 IF(matsto == 2 .OR. matsto == 3) THEN
8130 ! measurements - determine index-pairs
8131
8132 i=1
8133 DO WHILE (i <= lenmeasurements)
8134 i=i+2
8135 ! loop over label/factor pairs
8136 ia=i
8137 DO
8138 i=i+1
8139 IF(i > lenmeasurements) EXIT
8140 IF(listmeasurements(i)%label < 0) EXIT
8141 END DO
8142 ib=i-1
8143
8144 DO j=ia,ib
8145 itgbij=inone(listmeasurements(j)%label) ! total parameter index
8146 ! first index
8147 ivgbij=0
8148 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8149 DO k=ia,j
8150 itgbik=inone(listmeasurements(k)%label) ! total parameter index
8151 ! second index
8152 ivgbik=0
8153 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
8154 IF(ivgbij > 0.AND.ivgbik > 0) THEN
8156 IF (mprint > 1) WRITE(*,*) 'add index pair ',ivgbij,ivgbik
8157 END IF
8158 END DO
8159 END DO
8160
8161 END DO
8162 ELSE
8163 ! more checks for block diagonal structure
8164 ! loop over measurements
8165 i=1
8166 DO WHILE (i <= lenmeasurements)
8167 i=i+2
8168 ! loop over label/factor pairs
8169 ia=i
8170 DO
8171 i=i+1
8172 IF(i > lenmeasurements) EXIT
8173 IF(listmeasurements(i)%label < 0) EXIT
8174 END DO
8175 ib=i-1
8176 ij1=nvgb
8177 ijn=1
8178 DO j=ia,ib
8179 itgbij=inone(listmeasurements(j)%label) ! total parameter index
8180 ! first index
8181 ij=0
8182 IF(itgbij /= 0) ij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8183 IF (ij > 0) THEN
8184 ij1=min(ij1,ij)
8185 ijn=max(ijn,ij)
8186 END IF
8187 END DO
8188 globalindexranges(ij1)=max(globalindexranges(ij1),ijn)
8189 END DO
8190
8191 END IF
8192
8193 nummeas=0 ! number of measurement groups
8194 IF (imonit /= 0) THEN
8195 DO i=1,ntgb
8196 IF (measindex(i) > 0) THEN
8198 measres(i) = measres(i)/real(measindex(i),mpd)
8199 measindex(i) = nummeas
8200 END IF
8201 END DO
8202 length=nummeas*mthrd*measbins
8203 CALL mpalloc(meashists,length,'measurement counter')
8204 END IF
8205
8206 ! check for block diagonal structure, count blocks
8207 npblck=0
8208 l=0
8209 DO i=1,nvgb
8210 IF (i > l) npblck=npblck+1
8211 l=max(l,globalindexranges(i))
8212 globalindexranges(i)=npblck ! block number
8213 END DO
8214
8215 length=npblck+1; rows=2
8216 ! parameter blocks
8217 CALL mpalloc(matparblockoffsets,rows,length,'global parameter blocks (I)')
8219 CALL mpalloc(vecparblockconoffsets,length,'global parameter blocks (I)')
8221 ! fill matParBlocks
8222 l=0
8223 DO i=1,nvgb
8224 IF (globalindexranges(i) > l) THEN
8225 l=globalindexranges(i) ! block number
8226 matparblockoffsets(1,l)=i-1 ! block offset
8227 END IF
8228 END DO
8230 nparmx=0
8231 DO i=1,npblck
8232 rows=matparblockoffsets(1,i+1)-matparblockoffsets(1,i)
8233 nparmx=max(nparmx,int(rows,mpi))
8234 END DO
8235
8236 ! connect constraint blocks
8237 DO i=1,ncblck
8238 ia=matconsblocks(2,i) ! first parameter in constraint block
8239 IF (ia > matconsblocks(3,i)) cycle
8240 ib=globalindexranges(ia) ! parameter block number
8241 matparblockoffsets(2,ib+1)=i
8242 END DO
8243
8244 ! use diagonal block matrix storage?
8245 IF (npblck > 1) THEN
8246 IF (icheck > 0) THEN
8247 WRITE(*,*)
8248 DO i=1,npblck
8249 ia=matparblockoffsets(1,i)
8250 ib=matparblockoffsets(1,i+1)
8251 ja=matparblockoffsets(2,i)
8252 jb=matparblockoffsets(2,i+1)
8255 WRITE(*,*) ' Parameter block', i, ib-ia, jb-ja, labelf, labell
8256 ENDDO
8257 ENDIF
8258 WRITE(lunlog,*)
8259 WRITE(lunlog,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8260 WRITE(*,*)
8261 WRITE(*,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8262 IF ((metsol == 1.OR.metsol == 3.OR.metsol>=7).AND.nagb == nvgb) THEN
8263 WRITE(*,*) 'Using block diagonal storage mode'
8264 ELSE
8265 ! keep single block = full matrix
8266 DO i=1,2
8268 END DO
8269 npblck=1
8270 DO i=1,nvgb
8272 END DO
8273 END IF
8274 END IF
8275
8276 ! print numbers ----------------------------------------------------
8277
8278 IF (nagb >= 65536) THEN
8279 noff=int(noff8/1000,mpi)
8280 ELSE
8281 noff=int(noff8,mpi)
8282 END IF
8283 ndgn=0
8284 matwords=0
8285 IF(matsto == 2) THEN
8286 ihis=0
8287 IF (mhispe > 0) THEN
8288 ihis=15
8289 CALL hmpdef(ihis,0.0,real(mhispe,mps), 'NDBITS: #off-diagonal elements')
8290 END IF
8291 length=(napgrp+1)*nspc
8292 CALL mpalloc(sparsematrixoffsets,two,length, 'sparse matrix row offsets')
8294 ndgn=ndimsa(3)+ndimsa(4) ! actual number of off-diagonal elements
8295 matwords=ndimsa(2)+length*4 ! size of sparsity structure
8296
8297 IF (mhispe > 0) THEN
8298 IF (nhistp /= 0) CALL hmprnt(ihis)
8299 CALL hmpwrt(ihis)
8300 END IF
8301 END IF
8302 IF (matsto == 3) THEN
8303 length=nagb+1
8304 CALL mpalloc(csr3rowoffsets,length, 'sparse matrix row offsets (CSR3)')
8305 IF (mpdbsz > 1) THEN
8306 ! BSR3, check (for optimal) block size
8307 mbwrds=0
8308 DO i=1,mpdbsz
8309 npdblk=(nagb-1)/ipdbsz(i)+1
8310 length=int(npdblk,mpl)
8311 CALL mpalloc(vecblockcounts,length, 'sparse matrix row offsets (CSR3)')
8312 CALL pbsbits(globalallindexgroups,ipdbsz(i),nnzero,nblock,vecblockcounts)
8313 nbwrds=2*int(nblock,mpl)*int(ipdbsz(i)*ipdbsz(i)+1,mpl) ! number of words needed
8314 IF ((i == 1).OR.(nbwrds < mbwrds)) THEN
8315 matbsz=ipdbsz(i)
8316 mbwrds=nbwrds
8317 csr3rowoffsets(1)=1
8318 DO k=1,npdblk
8319 csr3rowoffsets(k+1)=csr3rowoffsets(k)+vecblockcounts(k)
8320 END DO
8321 END IF
8322 CALL mpdealloc(vecblockcounts)
8323 END DO
8324 ELSE
8325 ! CSR3
8327 !csr3RowOffsets(nvgb+2:)=csr3RowOffsets(nvgb+1) ! Lagrange multipliers (empty)
8328 END IF
8329 END IF
8330
8331 nagbn=maxglobalpar ! max number of global parameters in one event
8332 nalcn=maxlocalpar ! max number of local parameters in one event
8333 naeqn=maxequations ! max number of equations in one event
8336 ! matrices for event matrices
8337 ! split up cache
8338 IF (fcache(2) == 0.0) THEN ! from data (DSTAT)
8339 fcache(1)=real(dstat(1),mps)*fcache(1) ! leave some part free for fluctuations
8340 fcache(2)=real(dstat(2),mps)
8341 fcache(3)=real(dstat(3),mps)
8342 END IF
8343 fsum=fcache(1)+fcache(2)+fcache(3)
8344 DO k=1,3
8345 fcache(k)=fcache(k)/fsum
8346 END DO
8347 ncachr=nint(real(ncache,mps)*fcache(1),mpi) ! read cache
8348 ! define read buffer
8349 nc31=ncachr/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
8350 nwrd=nc31+1
8351 length=nwrd*mthrdr
8352 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
8353 nwrd=nc31*10+2+ndimbuf
8354 length=nwrd*mthrdr
8355 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
8356 CALL mpalloc(readbufferdatad,length,'read buffer, real')
8357 ! to read (old) float binary files
8358 length=(ndimbuf+2)*mthrdr
8359 CALL mpalloc(readbufferdataf,length,'read buffer, float')
8360
8361 ncachi=nint(real(ncache,mps)*fcache(2),mpi) ! index cache
8362 ncachd=ncache-ncachr-ncachi ! data cache
8363 nggd=(nagbn*nagbn+nagbn)/2+ncachd/(2*mthrd) ! number of double
8364 nggi=2+nagbn+ncachi/mthrd ! number of ints
8365 length=nagbn*mthrd
8366 CALL mpalloc(globalindexusage,length, 'global parameters (dim =max/event)')
8367 length=nvgb*mthrd
8368 CALL mpalloc(backindexusage,length,'global variable-index array')
8370 length=nagbn*nalcn
8371 CALL mpalloc(localglobalmatrix,length,'local/global matrix, content')
8372 CALL mpalloc(localglobalmap,length,'local/global matrix, map (counts)')
8373 length=2*nagbn*nalcn+nagbn+nalcn+1
8374 CALL mpalloc(localglobalstructure,length,'local/global matrix, (sparsity) structure')
8375 length=nggd*mthrd
8376 CALL mpalloc(writebufferupdates,length,'symmetric update matrices')
8377 writebufferheader(-1)=nggd ! number of words per thread
8378 writebufferheader(-2)=(nagbn*nagbn+nagbn)/2 ! min free (double) words
8379 length=nggi*mthrd
8380 CALL mpalloc(writebufferindices,length,'symmetric update matrix indices')
8381 rows=9; cols=mthrd
8382 CALL mpalloc(writebufferinfo,rows,cols,'write buffer status (I)')
8383 rows=2; cols=mthrd
8384 CALL mpalloc(writebufferdata,rows,cols,'write buffer status (F)')
8385 writebufferheader(1)=nggi ! number of words per thread
8386 writebufferheader(2)=nagbn+3 ! min free words
8387
8388 ! print all relevant dimension parameters
8389
8390 DO lu=6,8,2 ! unit 6 and 8
8391
8392 WRITE(lu,*) ' '
8393 WRITE(lu,101) 'NTGB',ntgb,'total number of parameters'
8394 WRITE(lu,102) '(all parameters, appearing in binary files)'
8395 WRITE(lu,101) 'NVGB',nvgb,'number of variable parameters'
8396 WRITE(lu,102) '(appearing in fit matrix/vectors)'
8397 WRITE(lu,101) 'NAGB',nagb,'number of all parameters'
8398 WRITE(lu,102) '(including Lagrange multiplier or reduced)'
8399 WRITE(lu,101) 'NTPGRP',ntpgrp,'total number of parameter groups'
8400 WRITE(lu,101) 'NVPGRP',nvpgrp,'number of variable parameter groups'
8401 WRITE(lu,101) 'NFGB',nfgb,'number of fit parameters'
8402 IF(metsol >= 4.AND. metsol <7) THEN ! band matrix as MINRES preconditioner
8403 WRITE(lu,101) 'MBANDW',mbandw,'band width of preconditioner matrix'
8404 WRITE(lu,102) '(if <0, no preconditioner matrix)'
8405 END IF
8406 IF (nagb >= 65536) THEN
8407 WRITE(lu,101) 'NOFF/K',noff,'max number of off-diagonal elements'
8408 ELSE
8409 WRITE(lu,101) 'NOFF',noff,'max number of off-diagonal elements'
8410 END IF
8411 IF(ndgn /= 0) THEN
8412 IF (nagb >= 65536) THEN
8413 WRITE(lu,101) 'NDGN/K',ndgn/1000,'actual number of off-diagonal elements'
8414 ELSE
8415 WRITE(lu,101) 'NDGN',ndgn,'actual number of off-diagonal elements'
8416 ENDIF
8417 ENDIF
8418 WRITE(lu,101) 'NCGB',ncgb,'number of constraints'
8419 WRITE(lu,101) 'NAGBN',nagbn,'max number of global parameters in an event'
8420 WRITE(lu,101) 'NALCN',nalcn,'max number of local parameters in an event'
8421 WRITE(lu,101) 'NAEQN',naeqn,'max number of equations in an event'
8422 IF (mprint > 1) THEN
8423 WRITE(lu,101) 'NAEQNA',naeqna,'number of equations'
8424 WRITE(lu,101) 'NAEQNG',naeqng, &
8425 'number of equations with global parameters'
8426 WRITE(lu,101) 'NAEQNF',naeqnf, &
8427 'number of equations with fixed global parameters'
8428 WRITE(lu,101) 'NRECF',nrecf, &
8429 'number of records with fixed global parameters'
8430 END IF
8431 IF (nrece > 0) THEN
8432 WRITE(lu,101) 'NRECE',nrece, &
8433 'number of records without variable parameters'
8434 END IF
8435 IF (ncache > 0) THEN
8436 WRITE(lu,101) 'NCACHE',ncache,'number of words for caching'
8437 WRITE(lu,111) (fcache(k)*100.0,k=1,3)
8438111 FORMAT(22x,'cache splitting ',3(f6.1,' %'))
8439 END IF
8440 WRITE(lu,*) ' '
8441
8442 WRITE(lu,*) ' '
8443 WRITE(lu,*) 'Solution method and matrix-storage mode:'
8444 IF(metsol == 1) THEN
8445 WRITE(lu,*) ' METSOL = 1: matrix inversion'
8446 ELSE IF(metsol == 2) THEN
8447 WRITE(lu,*) ' METSOL = 2: diagonalization'
8448 ELSE IF(metsol == 3) THEN
8449 WRITE(lu,*) ' METSOL = 3: decomposition'
8450 ELSE IF(metsol == 4) THEN
8451 WRITE(lu,*) ' METSOL = 4: MINRES (rtol', mrestl,')'
8452 ELSE IF(metsol == 5) THEN
8453 WRITE(lu,*) ' METSOL = 5: MINRES-QLP (rtol', mrestl,')'
8454 ELSE IF(metsol == 6) THEN
8455 WRITE(lu,*) ' METSOL = 6: GMRES'
8456#ifdef LAPACK64
8457 ELSE IF(metsol == 7) THEN
8458 WRITE(lu,*) ' METSOL = 7: LAPACK factorization'
8459 ELSE IF(metsol == 8) THEN
8460 WRITE(lu,*) ' METSOL = 8: LAPACK factorization'
8461#ifdef PARDISO
8462 ELSE IF(metsol == 9) THEN
8463 WRITE(lu,*) ' METSOL = 9: Intel oneMKL PARDISO'
8464#endif
8465#endif
8466 END IF
8467 WRITE(lu,*) ' with',mitera,' iterations'
8468 IF(matsto == 0) THEN
8469 WRITE(lu,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
8470 ELSE IF(matsto == 1) THEN
8471 WRITE(lu,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
8472 ELSE IF(matsto == 2) THEN
8473 WRITE(lu,*) ' MATSTO = 2: sparse matrix (custom)'
8474 ELSE IF(matsto == 3) THEN
8475 IF (matbsz < 2) THEN
8476 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
8477 ELSE
8478 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
8479 WRITE(lu,*) ' block size', matbsz
8480 END IF
8481 END IF
8482 IF(npblck > 1) THEN
8483 WRITE(lu,*) ' block diagonal with', npblck, ' blocks'
8484 END IF
8485 IF(mextnd>0) WRITE(lu,*) ' with extended storage'
8486 IF(dflim /= 0.0) THEN
8487 WRITE(lu,103) 'Convergence assumed, if expected dF <',dflim
8488 END IF
8489 IF(ncgb > 0) THEN
8490 IF(nfgb < nvgb) THEN
8491 IF (icelim > 1) THEN
8492 WRITE(lu,*) 'Constraints handled by elimination with LAPACK'
8493 ELSE
8494 WRITE(lu,*) 'Constraints handled by elimination'
8495 END IF
8496 ELSE
8497 WRITE(lu,*) 'Constraints handled by Lagrange multipliers'
8498 ENDIF
8499 END IF
8500
8501 END DO ! print loop
8502
8503 IF(nalcn == 0) THEN
8504 CALL peend(28,'Aborted, no local parameters')
8505 stop 'LOOP2: stopping due to missing local parameters'
8506 END IF
8507
8508 ! Wolfe conditions
8509
8510 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8511 IF(wolfc1 == 0.0) wolfc1=1.0e-4
8512 IF(wolfc2 == 0.0) wolfc2=0.9
8513 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8514 IF(wolfc1 <= 0.0) wolfc1=1.0e-4
8515 IF(wolfc2 >= 1.0) wolfc2=0.9
8516 IF(wolfc1 > wolfc2) THEN ! exchange
8517 wolfc3=wolfc1
8519 wolfc2=wolfc3
8520 ELSE
8521 wolfc1=1.0e-4
8522 wolfc2=0.9
8523 END IF
8524 WRITE(*,105) wolfc1,wolfc2
8525 WRITE(lun,105) wolfc1,wolfc2
8526105 FORMAT(' Constants C1, C2 for Wolfe conditions:',g12.4,', ',g12.4)
8527
8528 ! prepare matrix and gradient storage ------------------------------
852932 matsiz=0 ! number of words for double, single precision storage
8530 IF (matsto == 3) THEN ! sparse matrix (CSR3, BSR3)
8531 npdblk=(nagb-1)/matbsz+1 ! number of row blocks
8532 length=csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
8533 matsiz(1)=length*int(matbsz*matbsz,mpl)
8534 matwords=(length+nagb+1)*2 ! size of sparsity structure
8535 CALL mpalloc(csr3columnlist,length,'sparse matrix column list (CSR3)')
8536 IF (matbsz > 1) THEN
8538 ELSE
8540 END IF
8541 ELSE IF (matsto == 2) THEN ! sparse matrix (custom)
8542 matsiz(1)=ndimsa(3)+nagb
8543 matsiz(2)=ndimsa(4)
8544 CALL mpalloc(sparsematrixcolumns,ndimsa(2),'sparse matrix column list')
8546 CALL anasps ! analyze sparsity structure
8547 ELSE ! full or unpacked matrix, optional block diagonal
8548 length=nagb
8549 CALL mpalloc(globalrowoffsets,length,'global row offsets (full or unpacked (block) storage)')
8550 ! loop over blocks (multiple blocks only with elimination !)
8552 DO i=1,npblck
8553 ipoff=matparblockoffsets(1,i)
8554 icboff=matparblockoffsets(2,i) ! constraint block offset
8555 icblst=matparblockoffsets(2,i+1) ! constraint block offset
8556 npar=matparblockoffsets(1,i+1)-ipoff ! size of block (number of parameters)
8557 IF (icblst > icboff) THEN
8558 ncon=matconsblocks(1,icblst+1)-matconsblocks(1,icboff+1) ! number of constraints in (parameter) block
8559 ELSE
8560 ncon=0
8561 ENDIF
8563 nall = npar; IF (icelim <= 0) nall=npar+ncon ! add Lagrange multipliers
8564 DO k=1,nall
8565 globalrowoffsets(ipoff+k)=matsiz(1)-ipoff
8566 IF (matsto == 1) THEN
8567 matsiz(1)=matsiz(1)+k ! full ('triangular')
8568 ELSE
8569 matsiz(1)=matsiz(1)+nall ! unpacked ('quadratic')
8570 END IF
8571 END DO
8572 END DO
8573 END IF
8574 matwords=matwords+matsiz(1)*2+matsiz(2) ! #words for matrix storage
8575
8576 CALL feasma ! prepare constraint matrices
8577
8578 IF (icheck <= 0) CALL vmprep(matsiz) ! prepare matrix and gradient storage
8579 WRITE(*,*) ' '
8580 IF (matwords < 250000) THEN
8581 WRITE(*,*) 'Size of global matrix: < 1 MB'
8582 ELSE
8583 WRITE(*,*) 'Size of global matrix:',int(real(matwords,mps)*4.0e-6,mpi),' MB'
8584 ENDIF
8585 ! print chi^2 cut tables
8586
8587 ndfmax=naeqn-1
8588 WRITE(lunlog,*) ' '
8589 WRITE(lunlog,*) ' Cut values of Chi^2/Ndf and Chi2,'
8590 WRITE(lunlog,*) ' corresponding to 2 and 3 standard deviations'
8591 WRITE(lunlog,*) ' Ndf Chi^2/Ndf(2) Chi^2(2) ', &
8592 ' Chi^2/Ndf(3) Chi^2(3)'
8593 ndf=0
8594 DO
8595 IF(ndf > naeqn) EXIT
8596 IF(ndf < 10) THEN
8597 ndf=ndf+1
8598 ELSE IF(ndf < 20) THEN
8599 ndf=ndf+2
8600 ELSE IF(ndf < 100) THEN
8601 ndf=ndf+5
8602 ELSE IF(ndf < 200) THEN
8603 ndf=ndf+10
8604 ELSE
8605 EXIT
8606 END IF
8607 chin2=chindl(2,ndf)
8608 chin3=chindl(3,ndf)
8609 WRITE(lunlog,106) ndf,chin2,chin2*real(ndf,mps),chin3, chin3*real(ndf,mps)
8610 END DO
8611
8612 WRITE(lunlog,*) 'LOOP2: ending'
8613 WRITE(lunlog,*) ' '
8614 ! warnings from check input mode
8615 IF (icheck > 0) THEN
8616 IF (ncgbe /= 0) THEN
8617 WRITE(*,199) ' '
8618 WRITE(*,199) ' '
8619 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8620 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8621 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8622 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8623 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8624 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8625 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8626 WRITE(*,199) ' '
8627 WRITE(*,*) ' Number of empty constraints =',abs(ncgbe), ', should be 0'
8628 WRITE(*,*) ' => please check constraint definition, mille data'
8629 WRITE(*,199) ' '
8630 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8631 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8632 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8633 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8634 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8635 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8636 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8637 WRITE(*,199) ' '
8638 END IF
8639 END IF
8640 CALL mend
8641101 FORMAT(1x,a8,' =',i14,' = ',a)
8642102 FORMAT(22x,a)
8643103 FORMAT(1x,a,g12.4)
8644106 FORMAT(i6,2(3x,f9.3,f12.1,3x))
8645199 FORMAT(7x,a)
8646END SUBROUTINE loop2
8647
8652SUBROUTINE monres
8653 USE mpmod
8654 USE mpdalc
8655
8656 IMPLICIT NONE
8657 INTEGER(mpi) :: i
8658 INTEGER(mpi) :: ij
8659 INTEGER(mpi) :: imed
8660 INTEGER(mpi) :: j
8661 INTEGER(mpi) :: k
8662 INTEGER(mpi) :: nent
8663 INTEGER(mpi), DIMENSION(measBins) :: isuml ! location
8664 INTEGER(mpi), DIMENSION(measBins) :: isums ! scale
8665 REAL(mps) :: amed
8666 REAL(mps) :: amad
8667
8668 INTEGER(mpl) :: ioff
8669 LOGICAL :: lfirst
8670 SAVE
8671 DATA lfirst /.true./
8672
8673 ! combine data from threads
8674 ioff=0
8675 DO i=2,mthrd
8676 ioff=ioff+measbins*nummeas
8677 DO j=1,measbins*nummeas
8678 meashists(j)=meashists(j)+meashists(ioff+j)
8679 END DO
8680 END DO
8681
8682 IF (lfirst) THEN
8683 IF (imonmd == 0) THEN
8684 WRITE(lunmon,'(A)') '*** Normalized residuals grouped by first global label (per local fit cycle) ***'
8685 ELSE
8686 WRITE(lunmon,'(A)') '*** Pulls grouped by first global label (per local fit cycle) ***'
8687 ENDIF
8688 WRITE(lunmon,'(A)') '! LFC Label Entries Median RMS(MAD) <error>'
8689 lfirst=.false.
8690 END IF
8691
8692 !$POMP INST BEGIN(monres)
8693#ifdef SCOREP_USER_ENABLE
8694 scorep_user_region_by_name_begin("UR_monres", scorep_user_region_type_common)
8695#endif
8696 ! analyze histograms
8697 ioff=0
8698 DO i=1,ntgb
8699 IF (measindex(i) > 0) THEN
8700 isuml=0
8701 ! sum up content
8702 isuml(1)=meashists(ioff+1)
8703 DO j=2,measbins
8704 isuml(j)=isuml(j-1)+meashists(ioff+j)
8705 END DO
8706 nent=isuml(measbins)
8707 IF (nent > 0) THEN
8708 ! get median (for location)
8709 DO j=2,measbins
8710 IF (2*isuml(j) > nent) EXIT
8711 END DO
8712 imed=j
8713 amed=real(j,mps)
8714 IF (isuml(j) > isuml(j-1)) amed=amed+real(nent-2*isuml(j-1),mps)/real(2*isuml(j)-2*isuml(j-1),mps)
8715 amed=real(measbinsize,mps)*(amed-real(measbins/2,mps))
8716 ! sum up differences
8717 isums = 0
8718 DO j=imed,measbins
8719 k=j-imed+1
8720 isums(k)=isums(k)+meashists(ioff+j)
8721 END DO
8722 DO j=imed-1,1,-1
8723 k=imed-j
8724 isums(k)=isums(k)+meashists(ioff+j)
8725 END DO
8726 DO j=2, measbins
8727 isums(j)=isums(j)+isums(j-1)
8728 END DO
8729 ! get median (for scale)
8730 DO j=2,measbins
8731 IF (2*isums(j) > nent) EXIT
8732 END DO
8733 amad=real(j-1,mps)
8734 IF (isums(j) > isums(j-1)) amad=amad+real(nent-2*isums(j-1),mps)/real(2*isums(j)-2*isums(j-1),mps)
8735 amad=real(measbinsize,mps)*amad
8736 ELSE
8737 amed=0.0
8738 amad=0.0
8739 END IF
8740 ij=globalparlabelindex(1,i)
8741 WRITE(lunmon,110) nloopn, ij, nent, amed, amad*1.4826, real(measres(i),mps)
8742 !
8743 ioff=ioff+measbins
8744 END IF
8745 END DO
8746#ifdef SCOREP_USER_ENABLE
8747 scorep_user_region_by_name_end("UR_monres")
8748#endif
8749 !$POMP INST END(monres)
8750
8751110 FORMAT(i5,2i10,3g14.5)
8752END SUBROUTINE monres
8753
8754
8758
8759SUBROUTINE vmprep(msize)
8760 USE mpmod
8761 USE mpdalc
8762
8763 IMPLICIT NONE
8764 INTEGER(mpi) :: i
8765 INTEGER(mpi) :: ib
8766 INTEGER(mpi) :: ioff
8767 INTEGER(mpi) :: ipar0
8768 INTEGER(mpi) :: ncon
8769 INTEGER(mpi) :: npar
8770 INTEGER(mpi) :: nextra
8771#ifdef LAPACK64
8772 INTEGER :: nbopt, nboptx, ILAENV
8773#endif
8774 !
8775 INTEGER(mpl), INTENT(IN) :: msize(2)
8776
8777 INTEGER(mpl) :: length
8778 INTEGER(mpl) :: nwrdpc
8779 INTEGER(mpl), PARAMETER :: three = 3
8780
8781 SAVE
8782 ! ...
8783 ! Vector/matrix storage
8784 length=nagb*mthrd
8785 CALL mpalloc(globalvector,length,'rhs vector') ! double precision vector
8786 CALL mpalloc(globalcounter,length,'rhs counter') ! integer vector
8788 length=naeqn*mthrd
8789 CALL mpalloc(localcorrections,length,'residual vector of one record')
8790 CALL mpalloc(localequations,three,length,'mesurements indices (ISJAJB) of one record')
8791 length=nalcn*nalcn
8792 CALL mpalloc(aux,length,' local fit scratch array: aux')
8793 CALL mpalloc(vbnd,length,' local fit scratch array: vbnd')
8794 CALL mpalloc(vbdr,length,' local fit scratch array: vbdr')
8795 length=((nalcn+1)*nalcn)/2
8796 CALL mpalloc(clmat,length,' local fit matrix: clmat')
8797 CALL mpalloc(vbk,length,' local fit scratch array: vbk')
8798 length=nalcn
8799 CALL mpalloc(blvec,length,' local fit vector: blvec')
8800 CALL mpalloc(vzru,length,' local fit scratch array: vzru')
8801 CALL mpalloc(scdiag,length,' local fit scratch array: scdiag')
8802 CALL mpalloc(scflag,length,' local fit scratch array: scflag')
8803 CALL mpalloc(ibandh,2*length,' local fit band width hist.: ibandh')
8804
8805 CALL mpalloc(globalmatd,msize(1),'global matrix (D)' )
8806 CALL mpalloc(globalmatf,msize(2),'global matrix (F)')
8807
8808 mszpcc=0
8809 IF(metsol >= 4.AND.metsol < 7.AND. mbandw >= 0) THEN ! GMRES/MINRES algorithms
8810 ! array space is:
8811 ! variable-width band matrix or diagonal matrix for parameters
8812 ! followed by symmetric matrix for constraints
8813 ! followed by rectangular matrix for constraints
8814 nwrdpc=0
8815 ncon=nagb-nvgb ! number of Lagrange multipliers
8816 ! constraint block info
8817 length=4*ncblck; IF(ncon == 0) length=0
8818 CALL mpalloc(blockprecond,length,'preconditioner: constraint blocks')
8819 length=ncon
8820 CALL mpalloc(offprecond,length,'preconditioner: constraint offsets')
8821 !END IF
8822 ! variable-width band matrix ?
8823 IF(mbandw > 0) THEN
8824 length=nagb
8825 CALL mpalloc(indprecond,length,'pointer-array variable-band matrix')
8826 nwrdpc=nwrdpc+length
8827 DO i=1,min(mbandw,nvgb)
8828 indprecond(i)=(i*i+i)/2 ! increasing number
8829 END DO
8830 DO i=min(mbandw,nvgb)+1,nvgb
8831 indprecond(i)=indprecond(i-1)+mbandw ! fixed band width
8832 END DO
8833 DO i=nvgb+1,nagb ! reset
8834 indprecond(i)=0
8835 END DO
8836 END IF
8837 ! symmetric part
8838 length=(ncon*ncon+ncon)/2
8839 ! add 'band' part
8840 IF(mbandw > 0) THEN ! variable-width band matrix
8841 length=length+indprecond(nvgb)
8842 ELSE ! default preconditioner (diagonal)
8843 length=length+nvgb
8844 END IF
8845 ! add rectangular part (compressed, constraint blocks)
8846 IF(ncon > 0) THEN
8847 ioff=0
8848 ! extra space (for forward solution in EQUDEC)
8849 nextra=max(0,mbandw-1)
8850 DO ib=1,ncblck
8851 ! first constraint in block
8852 blockprecond(ioff+1)=matconsblocks(1,ib)
8853 ! last constraint in block
8854 blockprecond(ioff+2)=matconsblocks(1,ib+1)-1
8855 ! parameter offset
8856 ipar0=matconsblocks(2,ib)-1
8857 blockprecond(ioff+3)=ipar0
8858 ! number of parameters (-> columns)
8859 npar=matconsblocks(3,ib)-ipar0
8860 blockprecond(ioff+4)=npar+nextra
8861 DO i=blockprecond(ioff+1),blockprecond(ioff+2)
8862 offprecond(i)=length-ipar0
8863 length=length+npar+nextra
8864 mszpcc=mszpcc+npar+nextra
8865 END DO
8866 ioff=ioff+4
8867 END DO
8868 ELSE
8869 IF(mbandw == 0) length=length+1 ! for valid precons argument matPreCond((ncon*ncon+ncon)/2+nvgb+1)
8870 END IF
8871 ! allocate
8872 IF(mbandw > 0) THEN
8873 CALL mpalloc(matprecond,length,'variable-band preconditioner matrix')
8874 ELSE
8875 CALL mpalloc(matprecond,length,'default preconditioner matrix')
8876 END IF
8877 nwrdpc=nwrdpc+2*length
8878 IF (nwrdpc > 250000) THEN
8879 WRITE(*,*)
8880 WRITE(*,*) 'Size of preconditioner matrix:',int(real(nwrdpc,mps)*4.0e-6,mpi),' MB'
8881 END IF
8882
8883 END IF
8884
8885
8886 length=nagb
8887 CALL mpalloc(globalcorrections,length,'corrections') ! double prec corrections
8888
8889 length=nagb
8890 CALL mpalloc(workspaced,length,'auxiliary array (D1)') ! double aux 1
8891 CALL mpalloc(workspacelinesearch,length,'auxiliary array (D2)') ! double aux 2
8892 CALL mpalloc(workspacei, length,'auxiliary array (I)') ! int aux 1
8893
8894 IF(metsol == 1) THEN
8895 CALL mpalloc(workspacediag,length,'diagonal of global matrix)') ! double aux 1
8896 CALL mpalloc(workspacerow,length,'(pivot) row of global matrix)')
8897 ! CALL MEGARR('t D',2*NAGB,'auxiliary array') ! double aux 8
8898 END IF
8899
8900 IF(metsol == 2) THEN
8901 IF(nagb>46300) THEN
8902 CALL peend(23,'Aborted, bad matrix index (will exceed 32bit)')
8903 stop 'vmprep: bad index (matrix to large for diagonalization)'
8904 END IF
8905 CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8906 CALL mpalloc(workspacediagonalization,length,'auxiliary array (D3)') ! double aux 3
8907 CALL mpalloc(workspaceeigenvalues,length,'auxiliary array (D6)') ! double aux 6
8908 length=nagb*nagb
8909 CALL mpalloc(workspaceeigenvectors,length,'(rotation) matrix U') ! rotation matrix
8910 END IF
8911
8912 IF(metsol >= 4.AND.metsol < 7) THEN
8913 CALL mpalloc(vecxav,length,'vector X (AVPROD)') ! double aux 1
8914 CALL mpalloc(vecbav,length,'vector B (AVPROD)') ! double aux 1
8915 END IF
8916
8917#ifdef LAPACK64
8918 IF(metsol == 7) THEN
8919 IF(nagb > nvgb) CALL mpalloc(lapackipiv, length,'IPIV for DSPTRG (L)') ! pivot indices for DSPTRF
8920 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8921 END IF
8922 IF(metsol == 8) THEN
8923 IF(nagb > nvgb) THEN
8924 CALL mpalloc(lapackipiv, length,'LAPACK IPIV (L)')
8925 nbopt = ilaenv( 1_mpl, 'DSYTRF', 'U', int(nagb,mpl), int(nagb,mpl), -1_mpl, -1_mpl ) ! optimal block size
8926 print *
8927 print *, 'LAPACK optimal block size for DSYTRF:', nbopt
8928 lplwrk=length*int(nbopt,mpl)
8929 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8930 ELSE IF(nfgb < nvgb.AND.icelim > 1) THEN
8931 ! elimination of constraints with LAPACK
8932 lplwrk=1
8933 DO i=1,npblck
8934 npar=matparblockoffsets(1,i+1)-matparblockoffsets(1,i) ! number of parameters in block
8935 ncon=vecparblockconoffsets(i+1)-vecparblockconoffsets(i) ! number of constraints in block
8936 nbopt = ilaenv( 1_mpl, 'DORMQL', 'RN', int(npar,mpl), int(npar,mpl), int(ncon,mpl), int(npar,mpl) ) ! optimal buffer size
8937 IF (int(npar,mpl)*int(nbopt,mpl) > lplwrk) THEN
8938 lplwrk=int(npar,mpl)*int(nbopt,mpl)
8939 nboptx=nbopt
8940 END IF
8941 END DO
8942 print *
8943 print *, 'LAPACK optimal block size for DORMQL:', nboptx
8944 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8945 END IF
8946 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8947 END IF
8948#endif
8949
8950END SUBROUTINE vmprep
8951
8955
8956SUBROUTINE minver
8957 USE mpmod
8958
8959 IMPLICIT NONE
8960 INTEGER(mpi) :: i
8961 INTEGER(mpi) :: ib
8962 INTEGER(mpi) :: icoff
8963 INTEGER(mpi) :: ipoff
8964 INTEGER(mpi) :: j
8965 INTEGER(mpi) :: lun
8966 INTEGER(mpi) :: ncon
8967 INTEGER(mpi) :: nfit
8968 INTEGER(mpi) :: npar
8969 INTEGER(mpi) :: nrank
8970 INTEGER(mpl) :: imoff
8971 INTEGER(mpl) :: ioff1
8972 REAL(mpd) :: matij
8973
8974 EXTERNAL avprds
8975
8976 SAVE
8977 ! ...
8978 lun=lunlog ! log file
8979
8980 IF(icalcm == 1) THEN
8981 ! save diagonal (for global correlation)
8982 DO i=1,nagb
8983 workspacediag(i)=matij(i,i)
8984 END DO
8985 ! use elimination for constraints ?
8986 IF(nfgb < nvgb) THEN
8987 ! monitor progress
8988 IF(monpg1 > 0) THEN
8989 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
8991 END IF
8992 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
8993 IF(monpg1 > 0) CALL monend()
8994 END IF
8995 END IF
8996
8997 ! loop over blocks (multiple blocks only with elimination !)
8998 DO ib=1,npblck
8999 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9000 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9001 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9002 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9003 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9004 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9005 ! use elimination for constraints ?
9006 IF(nfit < npar) THEN
9007 CALL qlsetb(ib)
9008 ! solve L^t*y=d by backward substitution
9010 ! transform, reduce rhs
9011 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9012 ! correction from eliminated part
9013 DO i=1,nfit
9014 DO j=1,ncon
9015 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9017 END DO
9018 END DO
9019 END IF
9020
9021 IF(icalcm == 1) THEN
9022 ! monitor progress
9023 IF(monpg1 > 0) THEN
9024 WRITE(lunlog,*) 'Inversion of global matrix (A->A^-1)'
9026 END IF
9027 ! invert and solve
9028 CALL sqminl(globalmatd(imoff+1:), globalcorrections(ipoff+1:),nfit,nrank, &
9030 IF(monpg1 > 0) CALL monend()
9031 IF(nfit /= nrank) THEN
9032 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
9033 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9034 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
9035 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9036 IF (iforce == 0 .AND. isubit == 0) THEN
9037 isubit=1
9038 WRITE(*,*) ' --> enforcing SUBITO mode'
9039 WRITE(lun,*) ' --> enforcing SUBITO mode'
9040 END IF
9041 ELSE IF(ndefec == 0) THEN
9042 IF(npblck == 1) THEN
9043 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9044 ELSE
9045 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9046 END IF
9047 END IF
9048 ndefec=ndefec+nfit-nrank ! rank defect
9049
9050 ELSE ! multiply gradient by inverse matrix
9051 workspaced(:nfit)=globalcorrections(ipoff+1:ipoff+nfit)
9052 CALL dbsvxl(globalmatd(imoff+1:),workspaced,globalcorrections(ipoff+1:),nfit)
9053 END IF
9054
9055 !use elimination for constraints ?
9056 IF(nfit < npar) THEN
9057 ! extend, transform back solution
9058 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9059 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9060 END IF
9061 END DO
9062
9063END SUBROUTINE minver
9064
9068
9069SUBROUTINE mchdec
9070 USE mpmod
9071
9072 IMPLICIT NONE
9073 INTEGER(mpi) :: i
9074 INTEGER(mpi) :: ib
9075 INTEGER(mpi) :: icoff
9076 INTEGER(mpi) :: ipoff
9077 INTEGER(mpi) :: j
9078 INTEGER(mpi) :: lun
9079 INTEGER(mpi) :: ncon
9080 INTEGER(mpi) :: nfit
9081 INTEGER(mpi) :: npar
9082 INTEGER(mpi) :: nrank
9083 INTEGER(mpl) :: imoff
9084 INTEGER(mpl) :: ioff1
9085
9086 REAL(mpd) :: evmax
9087 REAL(mpd) :: evmin
9088
9089 EXTERNAL avprds
9090
9091 SAVE
9092 ! ...
9093 lun=lunlog ! log file
9094
9095 IF(icalcm == 1) THEN
9096 ! use elimination for constraints ?
9097 ! monitor progress
9098 IF(monpg1 > 0) THEN
9099 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9101 END IF
9102 IF(nfgb < nvgb) CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9103 IF(monpg1 > 0) CALL monend()
9104 END IF
9105
9106 ! loop over blocks (multiple blocks only with elimination !)
9107 DO ib=1,npblck
9108 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9109 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9110 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9111 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9112 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9113 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9114 ! use elimination for constraints ?
9115 IF(nfit < npar) THEN
9116 CALL qlsetb(ib)
9117 ! solve L^t*y=d by backward substitution
9119 ! transform, reduce rhs
9120 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9121 ! correction from eliminated part
9122 DO i=1,nfit
9123 DO j=1,ncon
9124 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9126 END DO
9127 END DO
9128 END IF
9129
9130 IF(icalcm == 1) THEN
9131 ! monitor progress
9132 IF(monpg1 > 0) THEN
9133 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
9135 END IF
9136 ! decompose and solve
9137 CALL chdec2(globalmatd(imoff+1:),nfit,nrank,evmax,evmin,monpg1)
9138 IF(monpg1 > 0) CALL monend()
9139 IF(nfit /= nrank) THEN
9140 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
9141 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9142 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
9143 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9144 IF (iforce == 0 .AND. isubit == 0) THEN
9145 isubit=1
9146 WRITE(*,*) ' --> enforcing SUBITO mode'
9147 WRITE(lun,*) ' --> enforcing SUBITO mode'
9148 END IF
9149 ELSE IF(ndefec == 0) THEN
9150 IF(npblck == 1) THEN
9151 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9152 ELSE
9153 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9154 END IF
9155 WRITE(lun,*) ' largest diagonal element (LDLt)', evmax
9156 WRITE(lun,*) ' smallest diagonal element (LDLt)', evmin
9157 END IF
9158 ndefec=ndefec+nfit-nrank ! rank defect
9159
9160 END IF
9161 ! backward/forward substitution
9162 CALL chslv2(globalmatd(imoff+1:),globalcorrections(ipoff+1:),nfit)
9163
9164 !use elimination for constraints ?
9165 IF(nfit < npar) THEN
9166 ! extend, transform back solution
9167 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9168 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9169 END IF
9170 END DO
9171
9172END SUBROUTINE mchdec
9173
9174#ifdef LAPACK64
9175
9180
9181SUBROUTINE mdptrf
9182 USE mpmod
9183
9184 IMPLICIT NONE
9185 INTEGER(mpi) :: i
9186 INTEGER(mpi) :: ib
9187 INTEGER(mpi) :: icoff
9188 INTEGER(mpi) :: ipoff
9189 INTEGER(mpi) :: j
9190 INTEGER(mpi) :: lun
9191 INTEGER(mpi) :: ncon
9192 INTEGER(mpi) :: nfit
9193 INTEGER(mpi) :: npar
9194 INTEGER(mpl) :: imoff
9195 INTEGER(mpl) :: ioff1
9196 INTEGER(mpi) :: infolp
9197 REAL(mpd) :: matij
9198
9199 EXTERNAL avprds
9200
9201 SAVE
9202 ! ...
9203 lun=lunlog ! log file
9204
9205 IF(icalcm == 1) THEN
9206 IF(ilperr == 1) THEN
9207 ! save diagonal (for global correlation)
9208 DO i=1,nagb
9209 workspacediag(i)=matij(i,i)
9210 END DO
9211 END IF
9212 ! use elimination for constraints ?
9213 IF(nfgb < nvgb) THEN
9214 ! monitor progress
9215 IF(monpg1 > 0) THEN
9216 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9218 END IF
9219 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9220 IF(monpg1 > 0) CALL monend()
9221 END IF
9222 END IF
9223
9224 ! loop over blocks (multiple blocks only with elimination !)
9225 DO ib=1,npblck
9226 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9227 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9228 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9229 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9230 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9231 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9232 ! use elimination for constraints ?
9233 IF(nfit < npar) THEN
9234 CALL qlsetb(ib)
9235 ! solve L^t*y=d by backward substitution
9237 ! transform, reduce rhs
9238 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
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)
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)'
9255 END IF
9256 !$POMP INST BEGIN(dsptrf)
9257#ifdef SCOREP_USER_ENABLE
9258 scorep_user_region_by_name_begin("UR_dsptrf", scorep_user_region_type_common)
9259#endif
9260 CALL dsptrf('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),infolp)
9261#ifdef SCOREP_USER_ENABLE
9262 scorep_user_region_by_name_end("UR_dsptrf")
9263#endif
9264 !$POMP INST END(dsptrf)
9265 IF(monpg1 > 0) CALL monend()
9266 ELSE
9267 ! monitor progress
9268 IF(monpg1 > 0) THEN
9269 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9271 END IF
9272 !$POMP INST BEGIN(dpptrf)
9273#ifdef SCOREP_USER_ENABLE
9274 scorep_user_region_by_name_begin("UR_dpptrf", scorep_user_region_type_common)
9275#endif
9276 CALL dpptrf('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
9277#ifdef SCOREP_USER_ENABLE
9278 scorep_user_region_by_name_end("UR_dpptrf")
9279#endif
9280 !$POMP INST END(dpptrf)
9281 IF(monpg1 > 0) CALL monend()
9282 ENDIF
9283 ! check result
9284 IF(infolp==0) THEN
9285 IF(npblck == 1) THEN
9286 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9287 ELSE
9288 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9289 END IF
9290 ELSE
9291 ndefec=ndefec+1 ! (lower limit of) rank defect
9292 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9293 '-by-',nfit,' failed at index ', infolp
9294 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9295 '-by-',nfit,' failed at index ', infolp
9296 CALL peend(29,'Aborted, factorization of global matrix failed')
9297 stop 'mdptrf: bad matrix'
9298 END IF
9299 END IF
9300 ! backward/forward substitution
9301 ! multipliers?
9302 IF (nfit > npar) THEN
9303 CALL dsptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),lapackipiv(ipoff+1:),&
9304 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9305 IF(infolp /= 0) print *, ' DSPTRS failed: ', infolp
9306 ELSE
9307 CALL dpptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),&
9308 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9309 IF(infolp /= 0) print *, ' DPPTRS failed: ', infolp
9310 ENDIF
9311
9312 !use elimination for constraints ?
9313 IF(nfit < npar) THEN
9314 ! extend, transform back solution
9315 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9316 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9317 END IF
9318 END DO
9319
9320END SUBROUTINE mdptrf
9321
9327
9328SUBROUTINE mdutrf
9329 USE mpmod
9330
9331 IMPLICIT NONE
9332 INTEGER(mpi) :: i
9333 INTEGER(mpi) :: ib
9334 INTEGER(mpi) :: icoff
9335 INTEGER(mpi) :: ipoff
9336 INTEGER(mpi) :: j
9337 INTEGER(mpi) :: lun
9338 INTEGER(mpi) :: ncon
9339 INTEGER(mpi) :: nfit
9340 INTEGER(mpi) :: npar
9341 INTEGER(mpl) :: imoff
9342 INTEGER(mpl) :: ioff1
9343 INTEGER(mpl) :: iloff
9344 INTEGER(mpi) :: infolp
9345
9346 REAL(mpd) :: matij
9347
9348 EXTERNAL avprds
9349
9350 SAVE
9351 ! ...
9352 lun=lunlog ! log file
9353
9354 IF(icalcm == 1) THEN
9355 IF(ilperr == 1) THEN
9356 ! save diagonal (for global correlation)
9357 DO i=1,nagb
9358 workspacediag(i)=matij(i,i)
9359 END DO
9360 END IF
9361 ! use elimination for constraints ?
9362 IF(nfgb < nvgb) THEN
9363 ! monitor progress
9364 IF(monpg1 > 0) THEN
9365 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9367 END IF
9368 IF (icelim > 1) THEN
9369 CALL lpavat(.true.)
9370 ELSE
9371 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9372 END IF
9373 IF(monpg1 > 0) CALL monend()
9374 END IF
9375 END IF
9376
9377 ! loop over blocks (multiple blocks only with elimination !)
9378 iloff=0 ! offset of L in lapackQL
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 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9385 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9386 ! use elimination for constraints ?
9387 IF(nfit < npar) THEN
9388 IF (icelim > 1) THEN
9389 ! solve L^t*y=d by backward substitution
9390 vecconssolution(1:ncon)=vecconsresiduals(icoff+1:icoff+ncon)
9391 CALL dtrtrs('L','T','N',int(ncon,mpl),1_mpl,lapackql(iloff+npar-ncon+1:),int(npar,mpl),&
9392 vecconssolution,int(ncon,mpl),infolp)
9393 IF(infolp /= 0) print *, ' DTRTRS failed: ', infolp
9394 ! transform, reduce rhs, Q^t*b
9395 CALL dormql('L','T',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9396 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9397 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9398 ELSE
9399 CALL qlsetb(ib)
9400 ! solve L^t*y=d by backward substitution
9402 ! transform, reduce rhs
9403 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9404 END IF
9405 ! correction from eliminated part
9406 DO i=1,nfit
9407 DO j=1,ncon
9408 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9410 END DO
9411 END DO
9412 END IF
9413
9414 IF(icalcm == 1) THEN
9415 ! multipliers?
9416 IF (nfit > npar) THEN
9417 ! monitor progress
9418 IF(monpg1 > 0) THEN
9419 WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
9421 END IF
9422 !$POMP INST BEGIN(dsytrf)
9423#ifdef SCOREP_USER_ENABLE
9424 scorep_user_region_by_name_begin("UR_dsytrf", scorep_user_region_type_common)
9425#endif
9426 CALL dsytrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
9427 lapackipiv(ipoff+1:),lapackwork,lplwrk,infolp)
9428#ifdef SCOREP_USER_ENABLE
9429 scorep_user_region_by_name_end("UR_dsytrf")
9430#endif
9431 !$POMP INST END(dsytrf)
9432 IF(monpg1 > 0) CALL monend()
9433 ELSE
9434 ! monitor progress
9435 IF(monpg1 > 0) THEN
9436 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9438 END IF
9439 !$POMP INST BEGIN(dpotrf)
9440#ifdef SCOREP_USER_ENABLE
9441 scorep_user_region_by_name_begin("UR_dpotrf", scorep_user_region_type_common)
9442#endif
9443 CALL dpotrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
9444#ifdef SCOREP_USER_ENABLE
9445 scorep_user_region_by_name_end("UR_dpotrf")
9446#endif
9447 !$POMP INST END(dpotrf)
9448 IF(monpg1 > 0) CALL monend()
9449 ENDIF
9450 ! check result
9451 IF(infolp==0) THEN
9452 IF(npblck == 1) THEN
9453 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9454 ELSE
9455 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9456 END IF
9457 ELSE
9458 ndefec=ndefec+1 ! (lower limit of) rank defect
9459 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9460 '-by-',nfit,' failed at index ', infolp
9461 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9462 '-by-',nfit,' failed at index ', infolp
9463 CALL peend(29,'Aborted, factorization of global matrix failed')
9464 stop 'mdutrf: bad matrix'
9465 END IF
9466 END IF
9467 ! backward/forward substitution
9468 ! multipliers?
9469 IF (nfit > npar) THEN
9470 CALL dsytrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(nfit,mpl),&
9471 lapackipiv(ipoff+1:),globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9472 IF(infolp /= 0) print *, ' DSYTRS failed: ', infolp
9473 ELSE
9474 CALL dpotrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(npar,mpl),&
9475 globalcorrections(ipoff+1:),int(npar,mpl),infolp)
9476 IF(infolp /= 0) print *, ' DPOTRS failed: ', infolp
9477 ENDIF
9478
9479 !use elimination for constraints ?
9480 IF(nfit < npar) THEN
9481 IF (icelim > 1) THEN
9482 ! correction from eliminated part
9483 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9484 ! extend, transform back solution, Q*x
9485 CALL dormql('L','N',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9486 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9487 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9488 ELSE
9489 ! extend, transform back solution
9490 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9491 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9492 END IF
9493 END IF
9494 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9495 END DO
9496
9497END SUBROUTINE mdutrf
9498
9509SUBROUTINE lpqldec(a,emin,emax)
9510 USE mpmod
9511 USE mpdalc
9512
9513 IMPLICIT NONE
9514 INTEGER(mpi) :: ib
9515 INTEGER(mpi) :: icb
9516 INTEGER(mpi) :: icboff
9517 INTEGER(mpi) :: icblst
9518 INTEGER(mpi) :: icoff
9519 INTEGER(mpi) :: icfrst
9520 INTEGER(mpi) :: iclast
9521 INTEGER(mpi) :: ipfrst
9522 INTEGER(mpi) :: iplast
9523 INTEGER(mpi) :: ipoff
9524 INTEGER(mpi) :: i
9525 INTEGER(mpi) :: j
9526 INTEGER(mpi) :: ncon
9527 INTEGER(mpi) :: npar
9528 INTEGER(mpi) :: npb
9529 INTEGER(mpl) :: imoff
9530 INTEGER(mpl) :: iloff
9531 INTEGER(mpi) :: infolp
9532 INTEGER :: nbopt, ILAENV
9533
9534 REAL(mpd), INTENT(IN) :: a(mszcon)
9535 REAL(mpd), INTENT(OUT) :: emin
9536 REAL(mpd), INTENT(OUT) :: emax
9537 SAVE
9538
9539 print *
9540 ! loop over blocks (multiple blocks only with elimination !)
9541 iloff=0 ! size of unpacked constraint matrix
9542 DO ib=1,npblck
9543 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9544 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9545 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9546 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9547 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9548 END DO
9549 ! allocate
9550 CALL mpalloc(lapackql, iloff, 'LAPACK QL (QL decomp.) ')
9551 lapackql=0.
9552 iloff=ncgb
9553 CALL mpalloc(lapacktau, iloff, 'LAPACK TAU (QL decomp.) ')
9554 ! fill
9555 iloff=0 ! offset of unpacked constraint matrix block
9556 imoff=0 ! offset of packed constraint matrix block
9557 DO ib=1,npblck
9558 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9559 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9560 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9561 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9562 IF(ncon <= 0) cycle
9563 ! block with constraints
9564 icboff=matparblockoffsets(2,ib) ! constraint block offset
9565 icblst=matparblockoffsets(2,ib+1) ! constraint block offset
9566 DO icb=icboff+1,icboff+icblst
9567 icfrst=matconsblocks(1,icb) ! first constraint in block
9568 iclast=matconsblocks(1,icb+1)-1 ! last constraint in block
9569 DO j=icfrst,iclast
9570 ipfrst=matconsranges(3,j)-ipoff ! first (rel.) parameter
9571 iplast=matconsranges(4,j)-ipoff ! last (rel.) parameters
9572 npb=iplast-ipfrst+1
9573 lapackql(iloff+ipfrst:iloff+iplast)=a(imoff+1:imoff+npb)
9574 imoff=imoff+npb
9575 iloff=iloff+npar
9576 END DO
9577 END DO
9578 END DO
9579 ! decompose
9580 iloff=0 ! offset of unpacked constraint matrix block
9581 emax=-1.
9582 emin=1.
9583 DO ib=1,npblck
9584 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9585 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9586 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9587 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9588 IF(ncon <= 0) cycle
9589 ! block with constraints
9590 nbopt = ilaenv( 1_mpl, 'DGEQLF', '', int(npar,mpl), int(ncon,mpl), int(npar,mpl), -1_mpl ) ! optimal block size
9591 print *, 'LAPACK optimal block size for DGEQLF:', nbopt
9592 lplwrk=int(ncon,mpl)*int(nbopt,mpl)
9593 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (d)')
9594 !$POMP INST BEGIN(dgeqlf)
9595#ifdef SCOREP_USER_ENABLE
9596 scorep_user_region_by_name_begin("UR_dgeqlf", scorep_user_region_type_common)
9597#endif
9598 CALL dgeqlf(int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9599 lapacktau(icoff+1:),lapackwork,lplwrk,infolp)
9600 IF(infolp /= 0) print *, ' DGEQLF failed: ', infolp
9601#ifdef SCOREP_USER_ENABLE
9602 scorep_user_region_by_name_end("UR_dgeqlf")
9603#endif
9604 !$POMP INST END(dgeqlf)
9605 CALL mpdealloc(lapackwork)
9606 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9607 ! get min/max diaginal element of L
9608 imoff=iloff
9609 IF(emax < emin) THEN
9610 emax=lapackql(imoff)
9611 emin=emax
9612 END IF
9613 DO i=1,ncon
9614 IF (abs(emax) < abs(lapackql(imoff))) emax=lapackql(imoff)
9615 IF (abs(emin) > abs(lapackql(imoff))) emin=lapackql(imoff)
9616 imoff=imoff-npar-1
9617 END DO
9618 END DO
9619 print *
9620END SUBROUTINE lpqldec
9621
9631SUBROUTINE lpavat(t)
9632 USE mpmod
9633
9634 IMPLICIT NONE
9635 INTEGER(mpi) :: i
9636 INTEGER(mpi) :: ib
9637 INTEGER(mpi) :: icoff
9638 INTEGER(mpi) :: ipoff
9639 INTEGER(mpi) :: j
9640 INTEGER(mpi) :: ncon
9641 INTEGER(mpi) :: npar
9642 INTEGER(mpl) :: imoff
9643 INTEGER(mpl) :: iloff
9644 INTEGER(mpi) :: infolp
9645 CHARACTER (LEN=1) :: transr, transl
9646
9647 LOGICAL, INTENT(IN) :: t
9648 SAVE
9649
9650 IF (t) THEN ! Q^t*A*Q
9651 transr='N'
9652 transl='T'
9653 ELSE ! Q*A*Q^t
9654 transr='T'
9655 transl='N'
9656 ENDIF
9657
9658 ! loop over blocks (multiple blocks only with elimination !)
9659 iloff=0 ! offset of L in lapackQL
9660 DO ib=1,npblck
9661 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9662 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9663 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9664 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9665 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9666 IF(ncon <= 0 ) cycle
9667
9668 !$POMP INST BEGIN(dormql)
9669#ifdef SCOREP_USER_ENABLE
9670 scorep_user_region_by_name_begin("UR_dormql", scorep_user_region_type_common)
9671#endif
9672 ! expand matrix (copy lower to upper triangle)
9673 ! parallelize row loop
9674 ! slot of 32 'I' for next idle thread
9675 !$OMP PARALLEL DO &
9676 !$OMP PRIVATE(J) &
9677 !$OMP SCHEDULE(DYNAMIC,32)
9678 DO i=ipoff+1,ipoff+npar
9679 DO j=ipoff+1,i-1
9681 ENDDO
9682 ENDDO
9683 ! A*Q
9684 CALL dormql('R',transr,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9685 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9686 lapackwork,lplwrk,infolp)
9687 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9688 ! Q^t*(A*Q)
9689 CALL dormql('L',transl,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9690 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9691 lapackwork,lplwrk,infolp)
9692 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9693#ifdef SCOREP_USER_ENABLE
9694 scorep_user_region_by_name_end("UR_dormql")
9695#endif
9696 !$POMP INST END(dormql)
9697
9698 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9699 END DO
9700
9701END SUBROUTINE lpavat
9702
9703#ifdef PARDISO
9704include 'mkl_pardiso.f90'
9705!===============================================================================
9706! Copyright 2004-2022 Intel Corporation.
9707!
9708! This software and the related documents are Intel copyrighted materials, and
9709! your use of them is governed by the express license under which they were
9710! provided to you (License). Unless the License provides otherwise, you may not
9711! use, modify, copy, publish, distribute, disclose or transmit this software or
9712! the related documents without Intel's prior written permission.
9713!
9714! This software and the related documents are provided as is, with no express
9715! or implied warranties, other than those that are expressly stated in the
9716! License.
9717!===============================================================================
9718!
9719! Content : Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO Fortran-90
9720! use case
9721!
9722!*******************************************************************************
9723
9728SUBROUTINE mspardiso
9729 USE mkl_pardiso
9730 USE mpmod
9731 USE mpdalc
9732 IMPLICIT NONE
9733
9734 !.. Internal solver memory pointer
9735 TYPE(mkl_pardiso_handle) :: pt(64) ! Handle to internal data structure
9736 !.. All other variables
9737 INTEGER(mpl), PARAMETER :: maxfct =1 ! Max. number of factors with identical sparsity structure kept in memory
9738 INTEGER(mpl), PARAMETER :: mnum = 1 ! Actual factor to use
9739 INTEGER(mpl), PARAMETER :: nrhs = 1 ! Number of right hand sides
9740
9741 INTEGER(mpl) :: mtype ! Matrix type (symmetric, pos. def.: 2, indef.: -2)
9742 INTEGER(mpl) :: phase ! Solver phase(s) to be executed
9743 INTEGER(mpl) :: error ! Error code
9744 INTEGER(mpl) :: msglvl ! Message level
9745
9746 INTEGER(mpi) :: i
9747 INTEGER(mpl) :: ij
9748 INTEGER(mpl) :: idum(1)
9749 INTEGER(mpi) :: lun
9750 INTEGER(mpl) :: length
9751 INTEGER(mpi) :: nfill
9752 INTEGER(mpi) :: npdblk
9753 REAL(mpd) :: adum(1)
9754 REAL(mpd) :: ddum(1)
9755
9756 INTEGER(mpl) :: iparm(64)
9757 REAL(mpd), ALLOCATABLE :: b( : ) ! Right hand side (of equations system)
9758 REAL(mpd), ALLOCATABLE :: x( : ) ! Solution (of equations system)
9759 SAVE
9760
9761 lun=lunlog ! log file
9762
9763 error = 0 ! initialize error flag
9764 msglvl = ipddbg ! print statistical information
9765 npdblk=(nfgb-1)/matbsz+1 ! number of row blocks
9766
9767 IF(icalcm == 1) THEN
9768 mtype = 2 ! positive definite symmetric matrix
9769 IF (nfgb > nvgb) mtype = -2 ! indefinte symmetric matrix (Lagrange multipliers)
9770
9771 !$POMP INST BEGIN(mspd00)
9772#ifdef SCOREP_USER_ENABLE
9773 scorep_user_region_by_name_begin("UR_mspd00", scorep_user_region_type_common)
9774#endif
9775 WRITE(*,*)
9776 WRITE(*,*) 'MSPARDISO: number of non-zero elements = ', csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
9777 ! fill up last block?
9778 nfill = npdblk*matbsz-nfgb
9779 IF (nfill > 0) THEN
9780 WRITE(*,*) 'MSPARDISO: number of rows to fill up = ', nfill
9781 ! end of last block
9782 ij = (csr3rowoffsets(npdblk+1)-csr3rowoffsets(1))*int(matbsz,mpl)*int(matbsz,mpl)
9783 DO i=1,nfill
9784 globalmatd(ij) = 1.0_mpd
9785 ij = ij-matbsz-1 ! back one row and one column in last block
9786 END DO
9787 END IF
9788
9789 ! close previous PARADISO run
9790 IF (ipdmem > 0) THEN
9791 !.. Termination and release of memory
9792 phase = -1 ! release internal memory
9793 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), adum, idum, idum, &
9794 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9795 IF (error /= 0) THEN
9796 WRITE(lun,*) 'The following ERROR was detected: ', error
9797 WRITE(*,'(A,2I10)') ' PARDISO release failed (phase, error): ', phase, error
9798 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9799 CALL peend(40,'Aborted, other error: PARDISO release')
9800 stop 'MSPARDISO: stopping due to error in PARDISO release'
9801 END IF
9802 ipdmem=0
9803 END IF
9804
9805 !..
9806 !.. Set up PARDISO control parameter
9807 !..
9808 iparm=0 ! using defaults
9809 iparm(2) = 2 ! fill-in reordering from METIS
9810 iparm(10) = 8 ! perturb the pivot elements with 1E-8
9811 iparm(18) = -1 ! Output: number of nonzeros in the factor LU
9812 iparm(19) = -1 ! Output: Mflops for LU factorization
9813 iparm(21) = 1 ! pivoting for symmetric indefinite matrices
9814 DO i=1, lenpardiso
9815 iparm(listpardiso(i)%label)=listpardiso(i)%ivalue
9816 END DO
9817 IF (iparm(1) == 0) WRITE(lun,*) 'PARDISO using defaults '
9818 IF (iparm(43) /= 0) THEN
9819 WRITE(lun,*) 'PARDISO: computation of the diagonal of inverse matrix not implemented !'
9820 iparm(43) = 0 ! no computation of the diagonal of inverse matrix
9821 END IF
9822
9823 ! necessary for the FIRST call of the PARDISO solver.
9824 DO i = 1, 64
9825 pt(i)%DUMMY = 0
9826 END DO
9827#ifdef SCOREP_USER_ENABLE
9828 scorep_user_region_by_name_end("UR_mspd00")
9829#endif
9830 !$POMP INST END(mspd00)
9831 END IF
9832
9833 IF(icalcm == 1) THEN
9834 ! monitor progress
9835 IF(monpg1 > 0) THEN
9836 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
9838 END IF
9839 ! decompose and solve
9840 !.. Reordering and Symbolic Factorization, This step also allocates
9841 ! all memory that is necessary for the factorization
9842 !$POMP INST BEGIN(mspd11)
9843#ifdef SCOREP_USER_ENABLE
9844 scorep_user_region_by_name_begin("UR_mspd11", scorep_user_region_type_common)
9845#endif
9846 phase = 11 ! only reordering and symbolic factorization
9847 IF (matbsz > 1) THEN
9848 iparm(1) = 1 ! non default setting
9849 iparm(37) = matbsz ! using BSR3 instead of CSR3
9850 END IF
9851 IF (ipddbg > 0) THEN
9852 DO i=1,64
9853 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9854 END DO
9855 END IF
9856 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9857 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9858#ifdef SCOREP_USER_ENABLE
9859 scorep_user_region_by_name_end("UR_mspd11")
9860#endif
9861 !$POMP INST END(mspd11)
9862 WRITE(lun,*) 'PARDISO reordering completed ... '
9863 WRITE(lun,*) 'PARDISO peak memory required (KB)', iparm(15)
9864 IF (ipddbg > 0) THEN
9865 DO i=1,64
9866 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9867 END DO
9868 END IF
9869 IF (error /= 0) THEN
9870 WRITE(lun,*) 'The following ERROR was detected: ', error
9871 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9872 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9873 CALL peend(40,'Aborted, other error: PARDISO reordering')
9874 stop 'MSPARDISO: stopping due to error in PARDISO reordering'
9875 END IF
9876 IF (iparm(60) == 0) THEN
9877 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(17) ! in core
9878 ELSE
9879 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(63) ! out of core
9880 END IF
9881 WRITE(lun,*) 'Size (KB) of allocated memory = ',ipdmem
9882 WRITE(lun,*) 'Number of nonzeros in factors = ',iparm(18)
9883 WRITE(lun,*) 'Number of factorization MFLOPS = ',iparm(19)
9884
9885 !.. Factorization.
9886 !$POMP INST BEGIN(mspd22)
9887#ifdef SCOREP_USER_ENABLE
9888 scorep_user_region_by_name_begin("UR_mspd22", scorep_user_region_type_common)
9889#endif
9890 phase = 22 ! only factorization
9891 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9892 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9893#ifdef SCOREP_USER_ENABLE
9894 scorep_user_region_by_name_end("UR_mspd22")
9895#endif
9896 !$POMP INST END(mspd22)
9897 WRITE(lun,*) 'PARDISO factorization completed ... '
9898 IF (ipddbg > 0) THEN
9899 DO i=1,64
9900 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9901 END DO
9902 END IF
9903 IF (error /= 0) THEN
9904 WRITE(lun,*) 'The following ERROR was detected: ', error
9905 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9906 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9907 CALL peend(40,'Aborted, other error: PARDISO factorization')
9908 stop 'MSPARDISO: stopping due to error in PARDISO factorization'
9909 ENDIF
9910 IF (mtype < 0) THEN
9911 IF (iparm(14) > 0) &
9912 WRITE(lun,*) 'Number of perturbed pivots = ',iparm(14)
9913 WRITE(lun,*) 'Number of positive eigenvalues = ',iparm(22)-nfill
9914 WRITE(lun,*) 'Number of negative eigenvalues = ',iparm(23)
9915 ELSE IF (iparm(30) > 0) THEN
9916 WRITE(lun,*) 'Equation with bad pivot (<=0.) = ',iparm(30)
9917 END IF
9918
9919 IF (monpg1 > 0) CALL monend()
9920 END IF
9921
9922 ! backward/forward substitution
9923 !.. Back substitution and iterative refinement
9924 length=nfgb+nfill
9925 CALL mpalloc(b,length,' PARDISO r.h.s')
9926 CALL mpalloc(x,length,' PARDISO solution')
9928 !$POMP INST BEGIN(mspd33)
9929#ifdef SCOREP_USER_ENABLE
9930 scorep_user_region_by_name_begin("UR_mspd33", scorep_user_region_type_common)
9931#endif
9932 iparm(6) = 0 ! don't update r.h.s. with solution
9933 phase = 33 ! only solving
9934 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9935 idum, nrhs, iparm, msglvl, b, x, error)
9936#ifdef SCOREP_USER_ENABLE
9937 scorep_user_region_by_name_end("UR_mspd33")
9938#endif
9939 !$POMP INST END(mspd33)
9941 CALL mpdealloc(x)
9942 CALL mpdealloc(b)
9943 WRITE(lun,*) 'PARDISO solve completed ... '
9944 IF (error /= 0) THEN
9945 WRITE(lun,*) 'The following ERROR was detected: ', error
9946 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9947 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9948 CALL peend(40,'Aborted, other error: PARDISO solve')
9949 stop 'MSPARDISO: stopping due to error in PARDISO solve'
9950 ENDIF
9951
9952END SUBROUTINE mspardiso
9953#endif
9954#endif
9955
9957SUBROUTINE mdiags
9958 USE mpmod
9959
9960 IMPLICIT NONE
9961 REAL(mps) :: evalue
9962 INTEGER(mpi) :: i
9963 INTEGER(mpi) :: iast
9964 INTEGER(mpi) :: idia
9965 INTEGER(mpi) :: imin
9966 INTEGER(mpl) :: ioff1
9967 INTEGER(mpi) :: j
9968 INTEGER(mpi) :: last
9969 INTEGER(mpi) :: lun
9970 INTEGER(mpi) :: nmax
9971 INTEGER(mpi) :: nmin
9972 INTEGER(mpi) :: ntop
9973 REAL(mpd) :: matij
9974 !
9975 EXTERNAL avprds
9976
9977 SAVE
9978 ! ...
9979
9980 lun=lunlog ! log file
9981
9982 ! save diagonal (for global correlation)
9983 IF(icalcm == 1) THEN
9984 DO i=1,nagb
9985 workspacediag(i)=matij(i,i)
9986 END DO
9987 ENDIF
9988
9989 !use elimination for constraints ?
9990 IF(nfgb < nvgb) THEN
9991 IF(icalcm == 1) THEN
9992 ! monitor progress
9993 IF(monpg1 > 0) THEN
9994 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9996 END IF
9997 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9998 IF(monpg1 > 0) CALL monend()
9999 ENDIF
10000 ! solve L^t*y=d by backward substitution
10002 ! transform, reduce rhs
10003 CALL qlmlq(globalcorrections,1,.true.) ! Q^t*b
10004 ! correction from eliminated part
10005 DO i=1,nfgb
10006 DO j=1,ncgb
10007 ioff1=globalrowoffsets(nfgb+j)+i ! global (nfit+j,i)
10009 END DO
10010 END DO
10011 END IF
10012
10013 IF(icalcm == 1) THEN
10014 ! eigenvalues eigenvectors symm_input
10015 workspaceeigenvalues=0.0_mpd
10018
10019 ! histogram of positive eigenvalues
10020
10021 nmax=int(1.0+log10(real(workspaceeigenvalues(1),mps)),mpi) ! > log of largest eigenvalue
10022 imin=1
10023 DO i=nfgb,1,-1
10024 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
10025 imin=i ! index of smallest pos. eigenvalue
10026 EXIT
10027 END IF
10028 END DO
10029 nmin=int(log10(real(workspaceeigenvalues(imin),mps)),mpi) ! log of smallest pos. eigenvalue
10030 ntop=nmin+6
10031 DO WHILE(ntop < nmax)
10032 ntop=ntop+3
10033 END DO
10034
10035 CALL hmpdef(7,real(nmin,mps),real(ntop,mps), 'log10 of positive eigenvalues')
10036 DO idia=1,nfgb
10037 IF(workspaceeigenvalues(idia) > 0.0_mpd) THEN ! positive
10038 evalue=log10(real(workspaceeigenvalues(idia),mps))
10039 CALL hmpent(7,evalue)
10040 END IF
10041 END DO
10042 IF(nhistp /= 0) CALL hmprnt(7)
10043 CALL hmpwrt(7)
10044
10045 iast=max(1,imin-60)
10046 CALL gmpdef(3,2,'low-value end of eigenvalues')
10047 DO i=iast,nfgb
10048 evalue=real(workspaceeigenvalues(i),mps)
10049 CALL gmpxy(3,real(i,mps),evalue)
10050 END DO
10051 IF(nhistp /= 0) CALL gmprnt(3)
10052 CALL gmpwrt(3)
10053
10054 DO i=1,nfgb
10055 workspacediagonalization(i)=0.0_mpd
10056 IF(workspaceeigenvalues(i) /= 0.0_mpd) THEN
10057 workspacediagonalization(i)=max(0.0_mpd,log10(abs(workspaceeigenvalues(i)))+3.0_mpd)
10059 END IF
10060 END DO
10061 last=min(nfgb,nvgb)
10062 WRITE(lun,*) ' '
10063 WRITE(lun,*) 'The first (largest) eigenvalues ...'
10064 WRITE(lun,102) (workspaceeigenvalues(i),i=1,min(20,nagb))
10065 WRITE(lun,*) ' '
10066 WRITE(lun,*) 'The last eigenvalues ... up to',last
10067 WRITE(lun,102) (workspaceeigenvalues(i),i=max(1,last-19),last)
10068 WRITE(lun,*) ' '
10069 IF(nagb > nvgb) THEN
10070 WRITE(lun,*) 'The eigenvalues from',nvgb+1,' to',nagb
10071 WRITE(lun,102) (workspaceeigenvalues(i),i=nvgb+1,nagb)
10072 WRITE(lun,*) ' '
10073 ENDIF
10074 WRITE(lun,*) 'Log10 + 3 of ',nfgb,' eigenvalues in decreasing', ' order'
10075 WRITE(lun,*) '(for Eigenvalue < 0.001 the value 0.0 is shown)'
10076 WRITE(lun,101) (workspacediagonalization(i),i=1,nfgb)
10077 IF(workspacediagonalization(nfgb) < 0) WRITE(lun,*) 'Negative values are ', &
10078 'printed for negative eigenvalues'
10080 WRITE(lun,*) ' '
10081 WRITE(lun,*) last,' significances: insignificant if ', &
10082 'compatible with N(0,1)'
10083 WRITE(lun,101) (workspacediagonalization(i),i=1,last)
10084
10085
10086101 FORMAT(10f7.1)
10087102 FORMAT(5e14.6)
10088
10089 END IF
10090
10091 ! solution ---------------------------------------------------------
10093 ! eigenvalues eigenvectors
10095
10096 !use elimination for constraints ?
10097 IF(nfgb < nvgb) THEN
10098 ! extend, transform back solution
10100 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10101 END IF
10102
10103END SUBROUTINE mdiags
10104
10106SUBROUTINE zdiags
10107 USE mpmod
10108
10109 IMPLICIT NONE
10110 INTEGER(mpi) :: i
10111 INTEGER(mpl) :: ioff1
10112 INTEGER(mpl) :: ioff2
10113 INTEGER(mpi) :: j
10114
10115 ! eigenvalue eigenvectors cov.matrix
10117
10118 !use elimination for constraints ?
10119 IF(nfgb < nvgb) THEN
10120 ! extend, transform eigenvectors
10121 ioff1=nfgb*nfgb
10122 ioff2=nfgb*nvgb
10123 workspaceeigenvectors(ioff2+1:)=0.0_mpd
10124 DO i=nfgb,1,-1
10125 ioff1=ioff1-nfgb
10126 ioff2=ioff2-nvgb
10127 DO j=nfgb,1,-1
10129 END DO
10130 workspaceeigenvectors(ioff2+nfgb+1:ioff2+nvgb)=0.0_mpd
10131 END DO
10132 CALL qlmlq(workspaceeigenvectors,nvgb,.false.) ! Q*U
10133 END IF
10134
10135END SUBROUTINE zdiags
10136
10142
10143SUBROUTINE mminrs
10144 USE mpmod
10145 USE minresmodule, ONLY: minres
10146
10147 IMPLICIT NONE
10148 INTEGER(mpi) :: istop
10149 INTEGER(mpi) :: itn
10150 INTEGER(mpi) :: itnlim
10151 INTEGER(mpi) :: lun
10152 INTEGER(mpi) :: nout
10153 INTEGER(mpi) :: nrkd
10154 INTEGER(mpi) :: nrkd2
10155
10156 REAL(mpd) :: shift
10157 REAL(mpd) :: rtol
10158 REAL(mpd) :: anorm
10159 REAL(mpd) :: acond
10160 REAL(mpd) :: arnorm
10161 REAL(mpd) :: rnorm
10162 REAL(mpd) :: ynorm
10163 LOGICAL :: checka
10164 EXTERNAL avprds, avprod, mvsolv, mcsolv
10165 SAVE
10166 ! ...
10167 lun=lunlog ! log file
10168
10169 nout=lun
10170 itnlim=2000 ! iteration limit
10171 shift =0.0_mpd ! not used
10172 rtol = mrestl ! from steering
10173 checka=.false.
10174
10176 !use elimination for constraints ?
10177 IF(nfgb < nvgb) THEN
10178 ! solve L^t*y=d by backward substitution
10180 ! input to AVPRD0
10181 vecxav(1:nfgb)=0.0_mpd
10183 CALL qlmlq(vecxav,1,.false.) ! Q*x
10184 ! calclulate vecBav=globalMat*vecXav
10185 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
10186 ! correction from eliminated part
10188 ! transform, reduce rhs
10189 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
10190 END IF
10191
10192 IF(mbandw == 0) THEN ! default preconditioner
10193 IF(icalcm == 1) THEN
10194 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
10195 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10196 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
10198 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
10199 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
10200 IF(monpg1 > 0) CALL monend()
10201 END IF
10202 CALL minres(nfgb, avprod, mcsolv, workspaced, shift, checka ,.true. , &
10203 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10204 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
10205 IF(icalcm == 1) THEN
10206 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
10207 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10208 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
10210 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
10211 IF(monpg1 > 0) CALL monend()
10212 END IF
10213 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.true. , &
10214 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10215 ELSE
10216 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.false. , &
10217 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10218 END IF
10219
10220 !use elimination for constraints ?
10221 IF(nfgb < nvgb) THEN
10222 ! extend, transform back solution
10224 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10225 END IF
10226
10227 iitera=itn
10228 istopa=istop
10229 mnrsit=mnrsit+itn
10230
10231 IF (istopa == 0) print *, 'MINRES: istop=0, exact solution x=0.'
10232
10233END SUBROUTINE mminrs
10234
10240
10241SUBROUTINE mminrsqlp
10242 USE mpmod
10243 USE minresqlpmodule, ONLY: minresqlp
10244
10245 IMPLICIT NONE
10246 INTEGER(mpi) :: istop
10247 INTEGER(mpi) :: itn
10248 INTEGER(mpi) :: itnlim
10249 INTEGER(mpi) :: lun
10250 INTEGER(mpi) :: nout
10251 INTEGER(mpi) :: nrkd
10252 INTEGER(mpi) :: nrkd2
10253
10254 REAL(mpd) :: rtol
10255 REAL(mpd) :: mxxnrm
10256 REAL(mpd) :: trcond
10257
10258 EXTERNAL avprds, avprod, mvsolv, mcsolv
10259 SAVE
10260 ! ...
10261 lun=lunlog ! log file
10262
10263 nout=lun
10264 itnlim=2000 ! iteration limit
10265 rtol = mrestl ! from steering
10266 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
10267 IF(mrmode == 1) THEN
10268 trcond = 1.0_mpd/epsilon(trcond) ! only QR
10269 ELSE IF(mrmode == 2) THEN
10270 trcond = 1.0_mpd ! only QLP
10271 ELSE
10272 trcond = mrtcnd ! QR followed by QLP
10273 END IF
10274
10276 !use elimination for constraints ?
10277 IF(nfgb < nvgb) THEN
10278 ! solve L^t*y=d by backward substitution
10280 ! input to AVPRD0
10281 vecxav(1:nfgb)=0.0_mpd
10283 CALL qlmlq(vecxav,1,.false.) ! Q*x
10284 ! calclulate vecBav=globalMat*vecXav
10285 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
10286 ! correction from eliminated part
10288 ! transform, reduce rhs
10289 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
10290 END IF
10291
10292 IF(mbandw == 0) THEN ! default preconditioner
10293 IF(icalcm == 1) THEN
10294 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
10295 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10296 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
10298 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
10299 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
10300 IF(monpg1 > 0) CALL monend()
10301 END IF
10302 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mcsolv, nout=nout, &
10303 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10304 x=globalcorrections, istop=istop, itn=itn)
10305 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
10306 IF(icalcm == 1) THEN
10307 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
10308 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10309 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
10311 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
10312 IF(monpg1 > 0) CALL monend()
10313 END IF
10314
10315 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mvsolv, nout=nout, &
10316 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10317 x=globalcorrections, istop=istop, itn=itn)
10318 ELSE
10319 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, nout=nout, &
10320 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10321 x=globalcorrections, istop=istop, itn=itn)
10322 END IF
10323
10324 !use elimination for constraints ?
10325 IF(nfgb < nvgb) THEN
10326 ! extend, transform back solution
10328 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10329 END IF
10330
10331 iitera=itn
10332 istopa=istop
10333 mnrsit=mnrsit+itn
10334
10335 IF (istopa == 3) print *, 'MINRES: istop=0, exact solution x=0.'
10336
10337END SUBROUTINE mminrsqlp
10338
10346
10347SUBROUTINE mcsolv(n,x,y) ! solve M*y = x
10348 USE mpmod
10349
10350 IMPLICIT NONE
10351 INTEGER(mpi),INTENT(IN) :: n
10352 REAL(mpd), INTENT(IN) :: x(n)
10353 REAL(mpd), INTENT(OUT) :: y(n)
10354 SAVE
10355 ! ...
10357 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),y,x)
10358END SUBROUTINE mcsolv
10359
10367
10368SUBROUTINE mvsolv(n,x,y) ! solve M*y = x
10369 USE mpmod
10370
10371 IMPLICIT NONE
10372
10373 INTEGER(mpi), INTENT(IN) :: n
10374 REAL(mpd), INTENT(IN) :: x(n)
10375 REAL(mpd), INTENT(OUT) :: y(n)
10376
10377 SAVE
10378 ! ...
10379 y=x ! copy to output vector
10380
10382END SUBROUTINE mvsolv
10383
10384
10385
10386!***********************************************************************
10387
10400
10401SUBROUTINE xloopn !
10402 USE mpmod
10403
10404 IMPLICIT NONE
10405 REAL(mps) :: catio
10406 REAL(mps) :: concu2
10407 REAL(mps) :: concut
10408 REAL, DIMENSION(2) :: ta
10409 REAL etime
10410 INTEGER(mpi) :: i
10411 INTEGER(mpi) :: iact
10412 INTEGER(mpi) :: iagain
10413 INTEGER(mpi) :: idx
10414 INTEGER(mpi) :: info
10415 INTEGER(mpi) :: ib
10416 INTEGER(mpi) :: ipoff
10417 INTEGER(mpi) :: icoff
10418 INTEGER(mpl) :: ioff
10419 INTEGER(mpi) :: itgbi
10420 INTEGER(mpi) :: ivgbi
10421 INTEGER(mpi) :: jcalcm
10422 INTEGER(mpi) :: k
10423 INTEGER(mpi) :: labelg
10424 INTEGER(mpi) :: litera
10425 INTEGER(mpl) :: lrej
10426 INTEGER(mpi) :: lun
10427 INTEGER(mpi) :: lunp
10428 INTEGER(mpi) :: minf
10429 INTEGER(mpi) :: mrati
10430 INTEGER(mpi) :: nan
10431 INTEGER(mpi) :: ncon
10432 INTEGER(mpi) :: nfaci
10433 INTEGER(mpi) :: nloopsol
10434 INTEGER(mpi) :: npar
10435 INTEGER(mpi) :: nrati
10436 INTEGER(mpl) :: nrej
10437 INTEGER(mpi) :: nsol
10438 INTEGER(mpi) :: inone
10439#ifdef LAPACK64
10440 INTEGER(mpi) :: infolp
10441 INTEGER(mpi) :: nfit
10442 INTEGER(mpl) :: imoff
10443#endif
10444
10445 REAL(mpd) :: stp
10446 REAL(mpd) :: dratio
10447 REAL(mpd) :: dwmean
10448 REAL(mpd) :: db
10449 REAL(mpd) :: db1
10450 REAL(mpd) :: db2
10451 REAL(mpd) :: dbdot
10452 REAL(mpd) :: dbsig
10453 LOGICAL :: btest
10454 LOGICAL :: warner
10455 LOGICAL :: warners
10456 LOGICAL :: warnerss
10457 LOGICAL :: warners3
10458 LOGICAL :: lsflag
10459 CHARACTER (LEN=7) :: cratio
10460 CHARACTER (LEN=7) :: cfacin
10461 CHARACTER (LEN=7) :: crjrat
10462 EXTERNAL avprds
10463 SAVE
10464 ! ...
10465
10466 ! Printout of algorithm for solution and important parameters ------
10467
10468 lun=lunlog ! log file
10469
10470 DO lunp=6,lunlog,lunlog-6
10471 WRITE(lunp,*) ' '
10472 WRITE(lunp,*) 'Solution algorithm: '
10473 WRITE(lunp,121) '=================================================== '
10474
10475 IF(metsol == 1) THEN
10476 WRITE(lunp,121) 'solution method:','matrix inversion'
10477 ELSE IF(metsol == 2) THEN
10478 WRITE(lunp,121) 'solution method:','diagonalization'
10479 ELSE IF(metsol == 3) THEN
10480 WRITE(lunp,121) 'solution method:','decomposition'
10481 ELSE IF(metsol == 4) THEN
10482 WRITE(lunp,121) 'solution method:', 'minres (Paige/Saunders)'
10483 ELSE IF(metsol == 5) THEN
10484 WRITE(lunp,121) 'solution method:', 'minres-qlp (Choi/Paige/Saunders)'
10485 IF(mrmode == 1) THEN
10486 WRITE(lunp,121) ' ', ' using QR factorization' ! only QR
10487 ELSE IF(mrmode == 2) THEN
10488 WRITE(lunp,121) ' ', ' using QLP factorization' ! only QLP
10489 ELSE
10490 WRITE(lunp,121) ' ', ' using QR and QLP factorization' ! QR followed by QLP
10491 WRITE(lunp,123) 'transition condition', mrtcnd
10492 END IF
10493 ELSE IF(metsol == 6) THEN
10494 WRITE(lunp,121) 'solution method:', &
10495 'gmres (generalized minimzation of residuals)'
10496#ifdef LAPACK64
10497 ELSE IF(metsol == 7) THEN
10498 IF (nagb > nvgb) THEN
10499 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSPTRF)'
10500 ELSE
10501 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPPTRF)'
10502 ENDIF
10503 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10504 ELSE IF(metsol == 8) THEN
10505 IF (nagb > nvgb) THEN
10506 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSYTRF)'
10507 ELSE
10508 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPOTRF)'
10509 ENDIF
10510 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10511#ifdef PARDISO
10512 ELSE IF(metsol == 9) THEN
10513 IF (matbsz < 2) THEN
10514 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (CSR3))'
10515 ELSE
10516 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (BSR3))'
10517 ENDIF
10518#endif
10519#endif
10520 END IF
10521 WRITE(lunp,123) 'convergence limit at Delta F=',dflim
10522 WRITE(lunp,122) 'maximum number of iterations=',mitera
10523 matrit=min(matrit,mitera)
10524 IF(matrit > 1) THEN
10525 WRITE(lunp,122) 'matrix recalculation up to ',matrit, '. iteration'
10526 END IF
10527 IF(metsol >= 4.AND.metsol < 7) THEN
10528 IF(matsto == 1) THEN
10529 WRITE(lunp,121) 'matrix storage:','full'
10530 ELSE IF(matsto == 2) THEN
10531 WRITE(lunp,121) 'matrix storage:','sparse'
10532 END IF
10533 WRITE(lunp,122) 'pre-con band-width parameter=',mbandw
10534 IF(mbandw == 0) THEN
10535 WRITE(lunp,121) 'pre-conditioning:','default'
10536 ELSE IF(mbandw < 0) THEN
10537 WRITE(lunp,121) 'pre-conditioning:','none!'
10538 ELSE IF(mbandw > 0) THEN
10539 IF(lprecm > 0) THEN
10540 WRITE(lunp,121) 'pre-conditioning=','skyline-matrix (rank preserving)'
10541 ELSE
10542 WRITE(lunp,121) 'pre-conditioning=','band-matrix'
10543 ENDIF
10544 END IF
10545 END IF
10546 IF(regpre == 0.0_mpd.AND.npresg == 0) THEN
10547 WRITE(lunp,121) 'using pre-sigmas:','no'
10548 ELSE
10549 ! FIXME: NPRESG contains parameters that failed the 'entries' cut...
10550 WRITE(lunp,124) 'pre-sigmas defined for', &
10551 REAL(100*npresg,mps)/REAL(nvgb,mps),' % of variable parameters'
10552 WRITE(lunp,123) 'default pre-sigma=',regpre
10553 END IF
10554 IF(nregul == 0) THEN
10555 WRITE(lunp,121) 'regularization:','no'
10556 ELSE
10557 WRITE(lunp,121) 'regularization:','yes'
10558 WRITE(lunp,123) 'regularization factor=',regula
10559 END IF
10560
10561 IF(chicut /= 0.0) THEN
10562 WRITE(lunp,121) 'Chi square cut equiv 3 st.dev applied'
10563 WRITE(lunp,123) '... in first iteration with factor',chicut
10564 WRITE(lunp,123) '... in second iteration with factor',chirem
10565 WRITE(lunp,121) ' (reduced by sqrt in next iterations)'
10566 END IF
10567 IF(iscerr > 0) THEN
10568 WRITE(lunp,121) 'Scaling of measurement errors applied'
10569 WRITE(lunp,123) '... factor for "global" measuements',dscerr(1)
10570 WRITE(lunp,123) '... factor for "local" measuements',dscerr(2)
10571 END IF
10572 IF(lhuber /= 0) THEN
10573 WRITE(lunp,122) 'Down-weighting of outliers in', lhuber,' iterations'
10574 WRITE(lunp,123) 'Cut on downweight fraction',dwcut
10575 END IF
10576
10577
10578121 FORMAT(1x,a40,3x,a)
10579122 FORMAT(1x,a40,3x,i0,a)
10580123 FORMAT(1x,a40,2x,e9.2)
10581124 FORMAT(1x,a40,3x,f5.1,a)
10582 END DO
10583
10584 ! initialization of iterations -------------------------------------
10585
10586 iitera=0
10587 nsol =0 ! counter for solutions
10588 info =0
10589 lsinfo=0
10590 stp =0.0_mpd
10591 stepl =real(stp,mps)
10592 concut=1.0e-12 ! initial constraint accuracy
10593 concu2=1.0e-06 ! constraint accuracy
10594 icalcm=1 ! require matrix calculation
10595 iterat=0 ! iteration counter
10596 iterat=-1
10597 litera=-2
10598 nloopsol=0 ! (new) solution from this nloopn
10599 nrej=0 ! reset number of rejects
10600 IF(metsol == 1) THEN
10601 wolfc2=0.5 ! not accurate
10602 minf=1
10603 ELSE IF(metsol == 2) THEN
10604 wolfc2=0.5 ! not acurate
10605 minf=2
10606 ELSE IF(metsol == 3) THEN
10607 wolfc2=0.5 ! not acurate
10608 minf=1
10609 ELSE IF(metsol == 4) THEN
10610 wolfc2=0.1 ! accurate
10611 minf=3
10612 ELSE IF(metsol == 5) THEN
10613 wolfc2=0.1 ! accurate
10614 minf=3
10615 ELSE IF(metsol == 6) THEN
10616 wolfc2=0.1 ! accurate
10617 minf=3
10618 ELSE
10619 wolfc2=0.5 ! not accurate
10620 minf=1
10621 END IF
10622
10623 ! check initial feasibility of constraint equations ----------------
10624
10625 WRITE(*,*) ' '
10626 IF(nofeas == 0) THEN ! make parameter feasible
10627 WRITE(lunlog,*) 'Checking feasibility of parameters:'
10628 WRITE(*,*) 'Checking feasibility of parameters:'
10629 CALL feasib(concut,iact) ! check feasibility
10630 IF(iact /= 0) THEN ! done ...
10631 WRITE(*,102) concut
10632 WRITE(*,*) ' parameters are made feasible'
10633 WRITE(lunlog,102) concut
10634 WRITE(lunlog,*) ' parameters are made feasible'
10635 ELSE ! ... was OK
10636 WRITE(*,*) ' parameters are feasible (i.e. satisfy constraints)'
10637 WRITE(lunlog,*) ' parameters are feasible (i.e. satisfy constraints)'
10638 END IF
10639 concut=concu2 ! cut for constraint check
10640 END IF
10641 iact=1 ! set flag for new data loop
10642 nofeas=0 ! set check-feasibility flag
10643
10644 WRITE(*,*) ' '
10645 WRITE(*,*)'Reading files and accumulating vectors/matrices ...'
10646 WRITE(*,*) ' '
10647 IF(monpg1>0) THEN
10648 WRITE(lunlog,*)
10649 WRITE(lunlog,*)'Reading files and accumulating vectors/matrices ...'
10650 WRITE(lunlog,*)
10651 END IF
10652
10653 rstart=etime(ta)
10654 iterat=-1
10655 litera= 0
10656 jcalcm=-1
10657 iagain= 0
10658
10659 icalcm=1
10660
10661 ! Block 1: data loop with vector (and matrix) calculation ----------
10662
10663 DO
10664 IF(iterat >= 0) THEN
10665 lcalcm=jcalcm+3 ! mode (1..4) of last loop
10666 IF(jcalcm+1 /= 0) THEN
10667 IF(iterat == 0) THEN
10668 CALL ploopa(6) ! header
10669 CALL ploopb(6)
10670 CALL ploopa(lunlog) ! iteration line
10671 CALL ploopb(lunlog)
10672 iterat=1
10673 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10674 ELSE
10675 IF(iterat /= litera) THEN
10676 CALL ploopb(6)
10677 ! CALL PLOOPA(LUNLOG)
10678 CALL ploopb(lunlog)
10679 litera=iterat
10680 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,delfun) ! fcn-value (with expected)
10681 IF(metsol == 4 .OR. metsol == 5) THEN ! extend to 6, i.e. GMRES?
10682 CALL gmpxy(2,real(iterat,mps),real(iitera,mps)) ! MINRES iterations
10683 END IF
10684 ELSE
10685 CALL ploopc(6) ! sub-iteration line
10686 CALL ploopc(lunlog)
10687 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10688 END IF
10689 END IF
10690 ELSE
10691 CALL ploopd(6) ! solution line
10692 CALL ploopd(lunlog)
10693 END IF
10694 rstart=etime(ta)
10695 ! CHK
10696 IF (iabs(jcalcm) <= 1) THEN
10697 idx=jcalcm+4
10698 times(idx )=(times(idx )*times(idx+3)+deltim) /(times(idx+3)+1.0)
10699 times(idx+3)= times(idx+3)+1.0
10700 END IF
10701 END IF
10702 jcalcm=icalcm
10703
10704 IF(icalcm >= 0) THEN ! ICALCM = +1 & 0
10705 CALL loopn ! data loop
10706 CALL addcst ! constraints
10707 lrej=nrej
10708 nrej=sum(nrejec) ! total number of rejects
10709 IF(3*nrej > nrecal) THEN
10710 WRITE(*,*) ' '
10711 WRITE(*,*) 'Data records rejected in previous loop: '
10712 CALL prtrej(6)
10713 WRITE(*,*) 'Too many rejects (>33.3%) - stop'
10714 CALL peend(26,'Aborted, too many rejects')
10715 stop
10716 END IF
10717 ! fill second half (j>i) of global matrix for extended storage, experimental
10718 IF (icalcm == 1.AND.mextnd > 0) CALL mhalf2()
10719 END IF
10720 ! Block 2: new iteration with calculation of solution --------------
10721 IF(abs(icalcm) == 1) THEN ! ICALCM = +1 & -1
10722 DO i=1,nagb
10723 globalcorrections(i)=globalvector(i) ! copy rhs
10724 END DO
10725 DO i=1,nvgb
10726 itgbi=globalparvartototal(i)
10727 workspacelinesearch(i)=globalparameter(itgbi) ! copy X for line search
10728 END DO
10729
10730 iterat=iterat+1 ! increase iteration count
10731 IF(metsol == 1) THEN
10732 CALL minver ! inversion
10733 ELSE IF(metsol == 2) THEN
10734 CALL mdiags ! diagonalization
10735 ELSE IF(metsol == 3) THEN
10736 CALL mchdec ! decomposition
10737 ELSE IF(metsol == 4) THEN
10738 CALL mminrs ! MINRES
10739 ELSE IF(metsol == 5) THEN
10740 CALL mminrsqlp ! MINRES-QLP
10741 ELSE IF(metsol == 6) THEN
10742 WRITE(*,*) '... reserved for GMRES (not yet!)'
10743 CALL mminrs ! GMRES not yet
10744#ifdef LAPACK64
10745 ELSE IF(metsol == 7) THEN
10746 CALL mdptrf ! LAPACK (packed storage)
10747 ELSE IF(metsol == 8) THEN
10748 CALL mdutrf ! LAPACK (unpacked storage)
10749#ifdef PARDISO
10750 ELSE IF(metsol == 9) THEN
10751 CALL mspardiso ! Intel oneMKL PARDISO (sparse matrix (CSR3, upper triangle))
10752#endif
10753#endif
10754 END IF
10755 nloopsol=nloopn ! (new) solution for this nloopn
10756
10757 ! check feasibility and evtl. make step vector feasible
10758
10759 DO i=1,nvgb
10760 itgbi=globalparvartototal(i)
10761 globalparcopy(itgbi)=globalparameter(itgbi) ! save
10762 globalparameter(itgbi)=globalparameter(itgbi)+globalcorrections(i) ! update
10763 END DO
10764 CALL feasib(concut,iact) ! improve constraints
10765 concut=concu2 ! new cut for constraint check
10766 DO i=1,nvgb
10767 itgbi=globalparvartototal(i)
10768 globalcorrections(i)=globalparameter(itgbi)-globalparcopy(itgbi) ! feasible stp
10769 globalparameter(itgbi)=globalparcopy(itgbi) ! restore
10770 END DO
10771
10774 db2=dbdot(nvgb,globalvector,globalvector)
10775 delfun=real(db,mps)
10776 angras=real(db/sqrt(db1*db2),mps)
10777 dbsig=16.0_mpd*sqrt(max(db1,db2))*epsilon(db) ! significant change
10778
10779 ! do line search for this iteration/solution ?
10780 ! lsearch >2: all, =2: all with (next) chicut =1., =1: last, <1: none
10781 lsflag=(lsearch > 2 .OR. (lsearch == 2 .AND. chicut < 2.25) .OR. &
10782 (lsearch == 1 .AND. chicut < 2.25 .AND. (delfun <= dflim .OR. iterat >= mitera)))
10783 lsflag=lsflag .AND. (db > dbsig) ! require significant change
10784 IF (lsflag) THEN
10785 ! initialize line search based on slopes and prepare next
10786 CALL ptldef(wolfc2, 10.0, minf,10)
10787 IF(metsol == 1) THEN
10788 wolfc2=0.5 ! not accurate
10789 minf=3
10790 ELSE IF(metsol == 2) THEN
10791 wolfc2=0.5 ! not acurate
10792 minf=3
10793 ELSE IF(metsol == 3) THEN
10794 wolfc2=0.5 ! not acurate
10795 minf=3
10796 ELSE IF(metsol == 4) THEN
10797 wolfc2=0.1 ! accurate
10798 minf=4
10799 ELSE IF(metsol == 5) THEN
10800 wolfc2=0.1 ! accurate
10801 minf=4
10802 ELSE IF(metsol == 6) THEN
10803 wolfc2=0.1 ! accurate
10804 minf=4
10805 ELSE
10806 wolfc2=0.5 ! not accurate
10807 minf=3
10808 END IF
10809 ENDIF
10810
10811 ! change significantly negative ?
10812 IF(db <= -dbsig) THEN
10813 WRITE(*,*) 'Function not decreasing:',db
10814 IF(db > -1.0e-3_mpd) THEN ! 100311, VB/CK: allow some margin for numerics
10815 iagain=iagain+1
10816 IF (iagain <= 1) THEN
10817 WRITE(*,*) '... again matrix calculation'
10818 icalcm=1
10819 cycle
10820 ELSE
10821 WRITE(*,*) '... aborting iterations'
10822 GO TO 90
10823 END IF
10824 ELSE
10825 WRITE(*,*) '... stopping iterations'
10826 iagain=-1
10827 GO TO 90
10828 END IF
10829 ELSE
10830 iagain=0
10831 END IF
10832 icalcm=0 ! switch
10833 ENDIF
10834 ! Block 3: line searching ------------------------------------------
10835
10836 IF(icalcm+2 == 0) EXIT
10837 IF (lsflag) THEN
10838 CALL ptline(nvgb,workspacelinesearch, & ! current parameter values
10839 flines, & ! chi^2 function value
10840 globalvector, & ! gradient
10841 globalcorrections, & ! step vector stp
10842 stp, & ! returned step factor
10843 info) ! returned information
10844 ! WRITE(*,*) 'PTLINE returns INFO, STP=',INFO, STP
10845 ELSE ! skip line search
10846 info=10
10847 stepl=1.0
10848 IF (nloopn == nloopsol) THEN ! new solution: update corrections
10850 ENDIF
10851 ENDIF
10852 lsinfo=info
10853
10854 stepl=real(stp,mps)
10855 nan=0
10856 DO i=1,nvgb
10857 itgbi=globalparvartototal(i)
10858 IF ((.NOT.(workspacelinesearch(i) <= 0.0_mpd)).AND. &
10859 (.NOT.(workspacelinesearch(i) > 0.0_mpd))) nan=nan+1
10860 globalparameter(itgbi)=workspacelinesearch(i) ! current parameter values
10861 END DO
10862
10863 IF (nan > 0) THEN
10864 WRITE(*,*) 'Result vector containes ', nan,' NaNs - stop'
10865 CALL peend(25,'Aborted, result vector contains NaNs')
10866 stop
10867 END IF
10868
10869 ! subito exit, if required -----------------------------------------
10870
10871 IF(isubit /= 0) THEN ! subito
10872 WRITE(*,*) 'Subito! Exit after first step.'
10873 GO TO 90
10874 END IF
10875
10876 IF(info == 0) THEN
10877 WRITE(*,*) 'INFO=0 should not happen (line search input err)'
10878 IF (iagain <= 0) THEN
10879 icalcm=1
10880 cycle
10881 ENDIF
10882 END IF
10883 IF(info < 0 .OR. nloopn == nloopsol) cycle
10884 ! Block 4: line search convergence ---------------------------------
10885
10886 CALL ptlprt(lunlog)
10887 CALL feasib(concut,iact) ! check constraints
10888 IF(iact /= 0.OR.chicut > 1.0) THEN
10889 icalcm=-1
10890 IF(iterat < matrit) icalcm=+1
10891 cycle ! iterate
10892 END IF
10893 IF(delfun <= dflim) GO TO 90 ! convergence
10894 IF(iterat >= mitera) GO TO 90 ! ending
10895 icalcm=-1
10896 IF(iterat < matrit) icalcm=+1
10897 cycle ! next iteration
10898
10899 ! Block 5: iteration ending ----------------------------------------
10900
1090190 icalcm=-2
10902 END DO
10903 IF(sum(nrejec) /= 0) THEN
10904 WRITE(*,*) ' '
10905 WRITE(*,*) 'Data records rejected in last loop: '
10906 CALL prtrej(6)
10907 END IF
10908
10909 ! monitoring of residuals
10910 IF (imonit > 0 .AND. btest(imonit,1)) CALL monres
10911 IF (lunmon > 0) CLOSE(unit=lunmon)
10912
10913 ! construct inverse from diagonalization
10914 IF(metsol == 2) CALL zdiags
10915
10916 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
10917#ifdef LAPACK64
10918 IF (metsol == 7.OR.metsol == 8) THEN
10919 ! inverse from factorization
10920 ! loop over blocks (multiple blocks only with elimination !)
10921 DO ib=1,npblck
10922 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10923 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
10924 icoff=vecparblockconoffsets(ib) ! constraint offset for block
10925 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
10926 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
10927 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
10928 IF (nfit > npar) THEN
10929 ! monitor progress
10930 IF(monpg1 > 0) THEN
10931 WRITE(lunlog,*) 'Inverse of global matrix from LDLt factorization'
10933 END IF
10934 IF (matsto == 1) THEN
10935 !$POMP INST BEGIN(dsptri)
10936#ifdef SCOREP_USER_ENABLE
10937 scorep_user_region_by_name_begin("UR_dsptri", scorep_user_region_type_common)
10938#endif
10939 CALL dsptri('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),workspaced,infolp)
10940 IF(infolp /= 0) print *, ' DSPTRI failed: ', infolp
10941#ifdef SCOREP_USER_ENABLE
10942 scorep_user_region_by_name_end("UR_dsptri")
10943#endif
10944 !$POMP INST END(dsptri)
10945 IF(monpg1 > 0) CALL monend()
10946 ELSE
10947 !$POMP INST BEGIN(dsytri)
10948#ifdef SCOREP_USER_ENABLE
10949 scorep_user_region_by_name_begin("UR_dsytri", scorep_user_region_type_common)
10950#endif
10951 CALL dsytri('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
10952 lapackipiv(ipoff+1:),workspaced,infolp)
10953 IF(infolp /= 0) print *, ' DSYTRI failed: ', infolp
10954#ifdef SCOREP_USER_ENABLE
10955 scorep_user_region_by_name_end("UR_dsytri")
10956#endif
10957 !$POMP INST END(dsytri)
10958 IF(monpg1 > 0) CALL monend()
10959 END IF
10960 ELSE
10961 IF(monpg1 > 0) THEN
10962 WRITE(lunlog,*) 'Inverse of global matrix from LLt factorization'
10964 END IF
10965 IF (matsto == 1) THEN
10966 !$POMP INST BEGIN(dpptri)
10967#ifdef SCOREP_USER_ENABLE
10968 scorep_user_region_by_name_begin("UR_dpptri", scorep_user_region_type_common)
10969#endif
10970 CALL dpptri('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
10971 IF(infolp /= 0) print *, ' DPPTRI failed: ', infolp
10972#ifdef SCOREP_USER_ENABLE
10973 scorep_user_region_by_name_end("UR_dpptri")
10974#endif
10975 !$POMP INST END(dpptri)
10976 ELSE
10977 !$POMP INST BEGIN(dpotri)
10978#ifdef SCOREP_USER_ENABLE
10979 scorep_user_region_by_name_begin("UR_dpotri", scorep_user_region_type_common)
10980#endif
10981 CALL dpotri('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
10982 IF(infolp /= 0) print *, ' DPOTRI failed: ', infolp
10983#ifdef SCOREP_USER_ENABLE
10984 scorep_user_region_by_name_end("UR_dpotri")
10985#endif
10986 !$POMP INST END(dpotri)
10987 END IF
10988 IF(monpg1 > 0) CALL monend()
10989 END IF
10990 END DO
10991 END IF
10992#endif
10993 !use elimination for constraints ?
10994 IF(nfgb < nvgb) THEN
10995 ! extend, transform matrix
10996 ! loop over blocks
10997 DO ib=1,npblck
10998 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10999 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
11000 icoff=vecparblockconoffsets(ib) ! constraint offset for block
11001 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
11002 DO i=npar-ncon+1,npar
11003 ioff=globalrowoffsets(i+ipoff)+ipoff
11004 globalmatd(ioff+1:ioff+i)=0.0_mpd
11005 END DO
11006 END DO
11007 ! monitor progress
11008 IF(monpg1 > 0) THEN
11009 WRITE(lunlog,*) 'Expansion of global matrix (A->Q*A*Q^t)'
11011 END IF
11012 IF(icelim < 2) THEN
11013 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.false.) ! Q*A*Q^t
11014#ifdef LAPACK64
11015 ELSE ! unpack storage, use LAPACK
11016 CALL lpavat(.false.)
11017#endif
11018 END IF
11019 IF(monpg1 > 0) CALL monend()
11020 END IF
11021 END IF
11022
11023 dwmean=sumndf/real(ndfsum,mpd)
11024 dratio=fvalue/dwmean/real(ndfsum-nfgb,mpd)
11025 catio=real(dratio,mps)
11026 IF(nloopn /= 1.AND.lhuber /= 0) THEN
11027 catio=catio/0.9326 ! correction Huber downweighting (in global chi2)
11028 END IF
11029 mrati=nint(100.0*catio,mpi)
11030
11031 DO lunp=6,lunlog,lunlog-6
11032 WRITE(lunp,*) ' '
11033 IF (nfilw <= 0) THEN
11034 WRITE(lunp,*) 'Sum(Chi^2)/Sum(Ndf) =',fvalue
11035 WRITE(lunp,*) ' / (',ndfsum,'-',nfgb,')'
11036 WRITE(lunp,*) ' =',dratio
11037 ELSE
11038 WRITE(lunp,*) 'Sum(W*Chi^2)/Sum(Ndf)/<W> =',fvalue
11039 WRITE(lunp,*) ' / (',ndfsum,'-', nfgb,')'
11040 WRITE(lunp,*) ' /',dwmean
11041 WRITE(lunp,*) ' =',dratio
11042 END IF
11043 WRITE(lunp,*) ' '
11044 IF(nloopn /= 1.AND.lhuber /= 0) WRITE(lunp,*) &
11045 ' with correction for down-weighting ',catio
11046 END DO
11047 nrej=sum(nrejec) ! total number of rejects
11048
11049 ! ... the end with exit code ???????????????????????????????????????
11050
11051 ! WRITE(*,199) ! write exit code
11052 ! + '-----------------------------------------------------------'
11053 ! IF(ITEXIT.EQ.0) WRITE(*,199)
11054 ! + 'Exit code = 0: Convergence reached'
11055 ! IF(ITEXIT.EQ.1) WRITE(*,199)
11056 ! + 'Exit code = 1: No improvement in last iteration'
11057 ! IF(ITEXIT.EQ.2) WRITE(*,199)
11058 ! + 'Exit code = 2: Maximum number of iterations reached'
11059 ! IF(ITEXIT.EQ.3) WRITE(*,199)
11060 ! + 'Exit code = 3: Failure'
11061 ! WRITE(*,199)
11062 ! + '-----------------------------------------------------------'
11063 ! WRITE(*,199) ' '
11064
11065
11066 nrati=nint(10000.0*real(nrej,mps)/real(nrecal,mps),mpi)
11067 WRITE(crjrat,197) 0.01_mpd*real(nrati,mpd)
11068 nfaci=nint(100.0*sqrt(catio),mpi)
11069
11070 WRITE(cratio,197) 0.01_mpd*real(mrati,mpd)
11071 WRITE(cfacin,197) 0.01_mpd*real(nfaci,mpd)
11072
11073 warner=.false. ! warnings
11074 IF(mrati < 90.OR.mrati > 110) warner=.true.
11075 IF(nrati > 100) warner=.true.
11076 IF(ncgbe /= 0) warner=.true.
11077 warners = .false. ! severe warnings
11078 IF(nalow /= 0) warners=.true.
11079 warnerss = .false. ! more severe warnings
11080 IF(nmiss1 /= 0) warnerss=.true.
11081 IF(iagain /= 0) warnerss=.true.
11082 IF(ndefec /= 0) warnerss=.true.
11083 IF(ndefpg /= 0) warnerss=.true.
11084 warners3 = .false. ! more severe warnings
11085 IF(nrderr /= 0) warners3=.true.
11086
11087 IF(warner.OR.warners.OR.warnerss.Or.warners3) THEN
11088 WRITE(*,199) ' '
11089 WRITE(*,199) ' '
11090 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
11091 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
11092 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
11093 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
11094 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
11095 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
11096 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
11097
11098 IF(mrati < 90.OR.mrati > 110) THEN
11099 WRITE(*,199) ' '
11100 WRITE(*,*) ' Chi^2/Ndf = ',cratio, ' (should be close to 1)'
11101 WRITE(*,*) ' => multiply all input standard ', &
11102 'deviations by factor',cfacin
11103 END IF
11104
11105 IF(nrati > 100) THEN
11106 WRITE(*,199) ' '
11107 WRITE(*,*) ' Fraction of rejects =',crjrat,' %', &
11108 ' (should be far below 1 %)'
11109 WRITE(*,*) ' => please provide correct mille data'
11110 CALL chkrej ! check (and print) rejection details
11111 END IF
11112
11113 IF(iagain /= 0) THEN
11114 WRITE(*,199) ' '
11115 WRITE(*,*) ' Matrix not positiv definite '// &
11116 '(function not decreasing)'
11117 WRITE(*,*) ' => please provide correct mille data'
11118 END IF
11119
11120 IF(ndefec /= 0) THEN
11121 WRITE(*,199) ' '
11122 WRITE(*,*) ' Rank defect =',ndefec, &
11123 ' for global matrix, should be 0'
11124 WRITE(*,*) ' => please provide correct mille data'
11125 END IF
11126
11127 IF(ndefpg /= 0) THEN
11128 WRITE(*,199) ' '
11129 WRITE(*,*) ' Rank defect for',ndefpg, &
11130 ' parameter groups, should be 0'
11131 WRITE(*,*) ' => please provide correct mille data'
11132 END IF
11133
11134 IF(nmiss1 /= 0) THEN
11135 WRITE(*,199) ' '
11136 WRITE(*,*) ' Rank defect =',nmiss1, &
11137 ' for constraint equations, should be 0'
11138 WRITE(*,*) ' => please correct constraint definition'
11139 END IF
11140
11141 IF(ncgbe /= 0) THEN
11142 WRITE(*,199) ' '
11143 WRITE(*,*) ' Number of empty constraints =',ncgbe, ', should be 0'
11144 WRITE(*,*) ' => please check constraint definition, mille data'
11145 END IF
11146
11147 IF(nxlow /= 0) THEN
11148 WRITE(*,199) ' '
11149 WRITE(*,*) ' Possible rank defects =',nxlow, ' for global matrix'
11150 WRITE(*,*) ' (too few accepted entries)'
11151 WRITE(*,*) ' => please check mille data and ENTRIES cut'
11152 END IF
11153
11154 IF(nalow /= 0) THEN
11155 WRITE(*,199) ' '
11156 WRITE(*,*) ' Possible bad elements =',nalow, ' in global vector'
11157 WRITE(*,*) ' (toos few accepted entries)'
11158 IF(ipcntr > 0) WRITE(*,*) ' (indicated in millepede.res by counts<0)'
11159 WRITE(*,*) ' => please check mille data and ENTRIES cut'
11160 END IF
11161
11162 IF(nrderr /= 0) THEN
11163 WRITE(*,199) ' '
11164 WRITE(*,*) ' Binary file(s) with read errors =',nrderr, ' (treated as EOF)'
11165 WRITE(*,*) ' => please check mille data'
11166 END IF
11167
11168 WRITE(*,199) ' '
11169 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
11170 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
11171 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
11172 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
11173 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
11174 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
11175 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
11176 WRITE(*,199) ' '
11177
11178 ENDIF
11179
11180 CALL mend ! modul ending
11181
11182 ! ------------------------------------------------------------------
11183
11184 IF(metsol == 1) THEN
11185
11186 ELSE IF(metsol == 2) THEN
11187 ! CALL zdiags moved up (before qlssq)
11188 ELSE IF(metsol == 3) THEN
11189 ! decomposition - nothing foreseen yet
11190 ELSE IF(metsol == 4 .OR. metsol == 5) THEN
11191 ! errors and correlations from MINRES
11192 DO k=1,mnrsel
11193 labelg=lbmnrs(k)
11194 IF(labelg == 0) cycle
11195 itgbi=inone(labelg)
11196 ivgbi=0
11197 IF(itgbi /= 0) ivgbi=globalparlabelindex(2,itgbi)
11198 IF(ivgbi < 0) ivgbi=0
11199 IF(ivgbi == 0) cycle
11200 ! determine error and global correlation for parameter IVGBI
11201 IF (metsol == 4) THEN
11202 CALL solglo(ivgbi)
11203 ELSE
11204 CALL solgloqlp(ivgbi)
11205 ENDIF
11206 END DO
11207
11208 ELSE IF(metsol == 6) THEN
11209
11210#ifdef LAPACK64
11211 ELSE IF(metsol == 7) THEN
11212 ! LAPACK - nothing foreseen yet
11213#endif
11214 END IF
11215
11216 CALL prtglo ! print result
11217
11218 IF (warners3) THEN
11219 CALL peend(4,'Ended with severe warnings (bad binary file(s))')
11220 ELSE IF (warnerss) THEN
11221 CALL peend(3,'Ended with severe warnings (bad global matrix)')
11222 ELSE IF (warners) THEN
11223 CALL peend(2,'Ended with severe warnings (insufficient measurements)')
11224 ELSE IF (warner) THEN
11225 CALL peend(1,'Ended with warnings (bad measurements)')
11226 ELSE
11227 CALL peend(0,'Ended normally')
11228 END IF
11229
11230102 FORMAT(' Call FEASIB with cut=',g10.3)
11231 ! 103 FORMAT(1X,A,G12.4)
11232197 FORMAT(f7.2)
11233199 FORMAT(7x,a)
11234END SUBROUTINE xloopn ! standard solution
11235
11236
11241
11242SUBROUTINE chkrej
11243 USE mpmod
11244 USE mpdalc
11245
11246 IMPLICIT NONE
11247 INTEGER(mpi) :: i
11248 INTEGER(mpi) :: kfl
11249 INTEGER(mpi) :: kmin
11250 INTEGER(mpi) :: kmax
11251 INTEGER(mpi) :: nrc
11252 INTEGER(mpl) :: nrej
11253
11254 REAL(mps) :: fmax
11255 REAL(mps) :: fmin
11256 REAL(mps) :: frac
11257
11258 REAL(mpd) :: sumallw
11259 REAL(mpd) :: sumrejw
11260
11261 sumallw=0.; sumrejw=0.;
11262 kmin=0; kmax=0;
11263 fmax=-1.; fmin=2;
11264
11265 DO i=1,nfilb
11266 kfl=kfd(2,i)
11267 nrc=-kfd(1,i)
11268 IF (nrc > 0) THEN
11269 nrej=nrc-jfd(kfl)
11270 sumallw=sumallw+real(nrc,mpd)*wfd(kfl)
11271 sumrejw=sumrejw+real(nrej,mpd)*wfd(kfl)
11272 frac=real(nrej,mps)/real(nrc,mps)
11273 IF (frac > fmax) THEN
11274 kmax=kfl
11275 fmax=frac
11276 END IF
11277 IF (frac < fmin) THEN
11278 kmin=kfl
11279 fmin=frac
11280 END IF
11281 END IF
11282 END DO
11283 IF (nfilw > 0) &
11284 WRITE(*,"(' Weighted fraction =',F8.2,' %')") 100.*sumrejw/sumallw
11285 IF (nfilb > 1) THEN
11286 WRITE(*,"(' File with max. fraction ',I6,' :',F8.2,' %')") kmax, 100.*fmax
11287 WRITE(*,"(' File with min. fraction ',I6,' :',F8.2,' %')") kmin, 100.*fmin
11288 END IF
11289
11290END SUBROUTINE chkrej
11291
11305
11306SUBROUTINE filetc
11307 USE mpmod
11308 USE mpdalc
11309
11310 IMPLICIT NONE
11311 INTEGER(mpi) :: i
11312 INTEGER(mpi) :: ia
11313 INTEGER(mpi) :: iargc
11314 INTEGER(mpi) :: ib
11315 INTEGER(mpi) :: ie
11316 INTEGER(mpi) :: ierrf
11317 INTEGER(mpi) :: ieq
11318 INTEGER(mpi) :: ifilb
11319 INTEGER(mpi) :: ioff
11320 INTEGER(mpi) :: iopt
11321 INTEGER(mpi) :: ios
11322 INTEGER(mpi) :: iosum
11323 INTEGER(mpi) :: it
11324 INTEGER(mpi) :: k
11325 INTEGER(mpi) :: mat
11326 INTEGER(mpi) :: nab
11327 INTEGER(mpi) :: nline
11328 INTEGER(mpi) :: npat
11329 INTEGER(mpi) :: ntext
11330 INTEGER(mpi) :: nu
11331 INTEGER(mpi) :: nuf
11332 INTEGER(mpi) :: nums
11333 INTEGER(mpi) :: nufile
11334 INTEGER(mpi) :: lenfileInfo
11335 INTEGER(mpi) :: lenFileNames
11336 INTEGER(mpi) :: matint
11337 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: vecfileInfo
11338 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArray
11339 INTEGER(mpl) :: rows
11340 INTEGER(mpl) :: cols
11341 INTEGER(mpl) :: newcols
11342 INTEGER(mpl) :: length
11343
11344 CHARACTER (LEN=1024) :: text
11345 CHARACTER (LEN=1024) :: fname
11346 CHARACTER (LEN=14) :: bite(3)
11347 CHARACTER (LEN=32) :: keystx
11348 INTEGER(mpi), PARAMETER :: mnum=100
11349 REAL(mpd) :: dnum(mnum)
11350
11351#ifdef READ_C_FILES
11352 INTERFACE
11353 SUBROUTINE initc(nfiles) BIND(c)
11354 USE iso_c_binding
11355 INTEGER(c_int), INTENT(IN), VALUE :: nfiles
11356 END SUBROUTINE initc
11357 END INTERFACE
11358#endif
11359
11360 SAVE
11361 DATA bite/'C_binary','text ','Fortran_binary'/
11362 ! ...
11363 CALL mstart('FILETC/X')
11364
11365 nuf=1 ! C binary is default
11366 DO i=1,8
11367 times(i)=0.0
11368 END DO
11369
11370 ! read command line options ----------------------------------------
11371
11372 filnam=' ' ! print command line options and find steering file
11373 DO i=1,iargc()
11374 IF(i == 1) THEN
11375 WRITE(*,*) ' '
11376 WRITE(*,*) 'Command line options: '
11377 WRITE(*,*) '--------------------- '
11378 END IF
11379 CALL getarg(i,text) ! get I.th text from command line
11380 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11381 WRITE(*,101) i,text(1:nab) ! echo print
11382 IF(text(ia:ia) /= '-') THEN
11383 nu=nufile(text(ia:ib)) ! inquire on file existence
11384 IF(nu == 2) THEN ! existing text file
11385 IF(filnam /= ' ') THEN
11386 WRITE(*,*) 'Second text file in command line - stop'
11387 CALL peend(12,'Aborted, second text file in command line')
11388 stop
11389 ELSE
11390 filnam=text
11391 END IF
11392 ELSE
11393 WRITE(*,*) 'Open error for file:',text(ia:ib),' - stop'
11394 CALL peend(16,'Aborted, open error for file')
11395 IF(text(ia:ia) /= '/') THEN
11396 CALL getenv('PWD',text)
11397 CALL rltext(text,ia,ib,nab)
11398 WRITE(*,*) 'PWD:',text(ia:ib)
11399 END IF
11400 stop
11401 END IF
11402 ELSE
11403 IF(index(text(ia:ib),'b') /= 0) THEN
11404 mdebug=3 ! debug flag
11405 WRITE(*,*) 'Debugging requested'
11406 END IF
11407 it=index(text(ia:ib),'t')
11408 IF(it /= 0) THEN
11409 ictest=1 ! internal test files
11410 ieq=index(text(ia+it:ib),'=')+it
11411 IF (it /= ieq) THEN
11412 IF (index(text(ia+ieq:ib),'SL0' ) /= 0) ictest=2
11413 IF (index(text(ia+ieq:ib),'SLE' ) /= 0) ictest=3
11414 IF (index(text(ia+ieq:ib),'BP' ) /= 0) ictest=4
11415 IF (index(text(ia+ieq:ib),'BRLF') /= 0) ictest=5
11416 IF (index(text(ia+ieq:ib),'BRLC') /= 0) ictest=6
11417 END IF
11418 END IF
11419 IF(index(text(ia:ib),'s') /= 0) isubit=1 ! like "subito"
11420 IF(index(text(ia:ib),'f') /= 0) iforce=1 ! like "force"
11421 IF(index(text(ia:ib),'c') /= 0) icheck=1 ! like "checkinput"
11422 IF(index(text(ia:ib),'C') /= 0) icheck=2 ! like "checkinput 2"
11423 END IF
11424 IF(i == iargc()) WRITE(*,*) '--------------------- '
11425 END DO
11426
11427
11428 ! create test files for option -t ----------------------------------
11429
11430 IF(ictest >= 1) THEN
11431 WRITE(*,*) ' '
11432 IF (ictest == 1) THEN
11433 CALL mptest ! 'wire chamber'
11434 ELSE
11435 CALL mptst2(ictest-2) ! 'silicon tracker'
11436 END IF
11437 IF(filnam == ' ') filnam='mp2str.txt'
11438 WRITE(*,*) ' '
11439 END IF
11440
11441 ! check default steering file with file-name "steerfile" -----------
11442
11443 IF(filnam == ' ') THEN ! check default steering file
11444 text='steerfile'
11445 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11446 nu=nufile(text(ia:ib)) ! inquire on file existence and type
11447 IF(nu > 0) THEN
11448 filnam=text
11449 ELSE
11450 CALL peend(10,'Aborted, no steering file')
11451 stop 'in FILETC: no steering file. .'
11452 END IF
11453 END IF
11454
11455
11456 ! open, read steering file:
11457 ! end
11458 ! fortranfiles
11459 ! cfiles
11460
11461
11462 CALL rltext(filnam,ia,ib,nfnam) ! return indices for non-blank area
11463 WRITE(*,*) ' '
11464 WRITE(*,*) 'Listing of steering file: ',filnam(1:nfnam)
11465 WRITE(*,*) '-------------------------'
11466 OPEN(10,file=filnam(1:nfnam),iostat=ios)
11467 IF(ios /= 0) THEN
11468 WRITE(*,*) 'Open error for steering file - stop'
11469 CALL peend(11,'Aborted, open error for steering file')
11470 IF(filnam(1:1) /= '/') THEN
11471 CALL getenv('PWD',text)
11472 CALL rltext(text,ia,ib,nab)
11473 WRITE(*,*) 'PWD:',text(ia:ib)
11474 END IF
11475 stop
11476 END IF
11477 ifile =0
11478 nfiles=0
11479
11480 lenfileinfo=2
11481 lenfilenames=0
11482 rows=6; cols=lenfileinfo
11483 CALL mpalloc(vecfileinfo,rows,cols,'file info from steering')
11484 nline=0
11485 DO
11486 READ(10,102,iostat=ierrf) text ! read steering file
11487 IF (ierrf < 0) EXIT ! eof
11488 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11489 nline=nline+1
11490 IF(nline <= 50) THEN ! print up to 50 lines
11491 WRITE(*,101) nline,text(1:nab)
11492 IF(nline == 50) WRITE(*,*) ' ...'
11493 END IF
11494 IF(ia == 0) cycle ! skip empty lines
11495
11496 CALL rltext(text,ia,ib,nab) ! test content 'end'
11497 IF(ib == ia+2) THEN
11498 mat=matint(text(ia:ib),'end',npat,ntext)
11499 IF(mat == max(npat,ntext)) THEN ! exact matching
11500 text=' '
11501 CALL intext(text,nline)
11502 WRITE(*,*) ' end-statement after',nline,' text lines'
11503 EXIT
11504 END IF
11505 END IF
11506
11507 keystx='fortranfiles'
11508 mat=matint(text(ia:ib),keystx,npat,ntext)
11509 IF(mat == max(npat,ntext)) THEN ! exact matching
11510 nuf=3
11511 ! WRITE(*,*) 'Fortran files'
11512 cycle
11513 END IF
11514
11515 keystx='Cfiles'
11516 mat=matint(text(ia:ib),keystx,npat,ntext)
11517 IF(mat == max(npat,ntext)) THEN ! exact matching
11518 nuf=1
11519 ! WRITE(*,*) 'Cfiles'
11520 cycle
11521 END IF
11522
11523 keystx='closeandreopen' ! don't keep binary files open
11524 mat=matint(text(ia:ib),keystx,npat,ntext)
11525 IF(mat == max(npat,ntext)) THEN ! exact matching
11526 keepopen=0
11527 cycle
11528 END IF
11529
11530 ! file names
11531 ! check for file options (' -- ')
11532 ie=ib
11533 iopt=index(text(ia:ib),' -- ')
11534 IF (iopt > 0) ie=iopt-1
11535
11536 IF(nab == 0) cycle
11537 nu=nufile(text(ia:ie)) ! inquire on file existence
11538 IF(nu > 0) THEN ! existing file
11539 IF (nfiles == lenfileinfo) THEN ! increase length
11540 CALL mpalloc(temparray,rows,cols,'temp file info from steering')
11541 temparray=vecfileinfo
11542 CALL mpdealloc(vecfileinfo)
11543 lenfileinfo=lenfileinfo*2
11544 newcols=lenfileinfo
11545 CALL mpalloc(vecfileinfo,rows,newcols,'file info from steering')
11546 vecfileinfo(:,1:cols)=temparray(:,1:cols)
11547 CALL mpdealloc(temparray)
11548 cols=newcols
11549 ENDIF
11550 nfiles=nfiles+1 ! count number of files
11551 IF(nu == 1) nu=nuf !
11552 lenfilenames=lenfilenames+ie-ia+1 ! total length of file names
11553 vecfileinfo(1,nfiles)=nline ! line number
11554 vecfileinfo(2,nfiles)=nu ! cbinary =1, text =2, fbinary=3
11555 vecfileinfo(3,nfiles)=ia ! file name start
11556 vecfileinfo(4,nfiles)=ie ! file name end
11557 vecfileinfo(5,nfiles)=iopt ! option start
11558 vecfileinfo(6,nfiles)=ib ! option end
11559 ELSE
11560 ! WRITE(*,*) 'Open error for file ',TEXT(IA:IB)
11561 ! STOP
11562 END IF
11563 END DO
11564 rewind 10
11565 ! read again to fill dynamic arrays with file info
11566 length=nfiles
11567 CALL mpalloc(mfd,length,'file type')
11568 CALL mpalloc(nfd,length,'file line (in steering)')
11569 CALL mpalloc(lfd,length,'file name length')
11570 CALL mpalloc(ofd,length,'file option')
11571 length=lenfilenames
11572 CALL mpalloc(tfd,length,'file name')
11573 nline=0
11574 i=1
11575 ioff=0
11576 DO
11577 READ(10,102,iostat=ierrf) text ! read steering file
11578 IF (ierrf < 0) EXIT ! eof
11579 nline=nline+1
11580 IF (nline == vecfileinfo(1,i)) THEN
11581 nfd(i)=vecfileinfo(1,i)
11582 mfd(i)=vecfileinfo(2,i)
11583 ia=vecfileinfo(3,i)-1
11584 lfd(i)=vecfileinfo(4,i)-ia ! length file name
11585 DO k=1,lfd(i)
11586 tfd(ioff+k)=text(ia+k:ia+k)
11587 END DO
11588 ! tfd(i)=text(vecFileInfo(3,i):vecFileInfo(4,i)) ! file name
11589 ioff=ioff+lfd(i)
11590 ofd(i)=1.0 ! option for file
11591 IF (vecfileinfo(5,i) > 0) THEN
11592 CALL ratext(text(vecfileinfo(5,i)+4:vecfileinfo(6,i)),nums,dnum,mnum) ! translate text to DP numbers
11593 IF (nums > 0) ofd(i)=real(dnum(1),mps)
11594 END IF
11595 i=i+1
11596 IF (i > nfiles) EXIT
11597 ENDIF
11598 ENDDO
11599 CALL mpdealloc(vecfileinfo)
11600 rewind 10
11601 ! additional info for binary files
11602 length=nfiles; rows=2
11603 CALL mpalloc(ifd,length,'integrated record numbers (=offset)')
11604 CALL mpalloc(jfd,length,'number of accepted records')
11605 CALL mpalloc(kfd,rows,length,'number of records in file, file order')
11606 CALL mpalloc(dfd,length,'ndf sum')
11607 CALL mpalloc(xfd,length,'max. record size')
11608 CALL mpalloc(wfd,length,'file weight')
11609 CALL mpalloc(cfd,length,'chi2 sum')
11610 CALL mpalloc(sfd,rows,length,'start, end of file name in TFD')
11611 CALL mpalloc(yfd,length,'modification date')
11612 yfd=0
11613 !
11614 WRITE(*,*) '-------------------------'
11615 WRITE(*,*) ' '
11616
11617 ! print table of files ---------------------------------------------
11618
11619 IF (mprint > 1) THEN
11620 WRITE(*,*) 'Table of files:'
11621 WRITE(*,*) '---------------'
11622 END IF
11623 WRITE(8,*) ' '
11624 WRITE(8,*) 'Text and data files:'
11625 ioff=0
11626 DO i=1,nfiles
11627 DO k=1,lfd(i)
11628 fname(k:k)=tfd(ioff+k)
11629 END DO
11630 ! fname=tfd(i)(1:lfd(i))
11631 IF (mprint > 1) WRITE(*,103) i,bite(mfd(i)),fname(1:lfd(i))
11632 WRITE(8,103) i,bite(mfd(i)),fname(1:lfd(i))
11633 ioff=ioff+lfd(i)
11634 END DO
11635 IF (mprint > 1) THEN
11636 WRITE(*,*) '---------------'
11637 WRITE(*,*) ' '
11638 END IF
11639
11640 ! open the binary Fortran (data) files on unit 11, 12, ...
11641
11642 iosum=0
11643 nfilf=0
11644 nfilb=0
11645 nfilw=0
11646 ioff=0
11647 ifilb=0
11648 IF (keepopen < 1) ifilb=1
11649 DO i=1,nfiles
11650 IF(mfd(i) == 3) THEN
11651 nfilf=nfilf+1
11652 nfilb=nfilb+1
11653 ! next file name
11654 sfd(1,nfilb)=ioff
11655 sfd(2,nfilb)=lfd(i)
11656 CALL binopn(nfilb,ifilb,ios)
11657 IF(ios == 0) THEN
11658 wfd(nfilb)=ofd(i)
11659 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11660 ELSE ! failure
11661 iosum=iosum+1
11662 nfilf=nfilf-1
11663 nfilb=nfilb-1
11664 END IF
11665 END IF
11666 ioff=ioff+lfd(i)
11667 END DO
11668
11669 ! open the binary C files
11670
11671 nfilc=-1
11672 ioff=0
11673 DO i=1,nfiles ! Cfiles
11674 IF(mfd(i) == 1) THEN
11675#ifdef READ_C_FILES
11676 IF(nfilc < 0) THEN ! initialize
11677 CALL initc(max(nfiles,mthrdr)) ! uncommented by GF
11678 nfilc=0
11679 END IF
11680 nfilc=nfilc+1
11681 nfilb=nfilb+1
11682 ! next file name
11683 sfd(1,nfilb)=ioff
11684 sfd(2,nfilb)=lfd(i)
11685 CALL binopn(nfilb,ifilb,ios)
11686 IF(ios == 0) THEN
11687 wfd(nfilb)=ofd(i)
11688 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11689 ELSE ! failure
11690 iosum=iosum+1
11691 nfilc=nfilc-1
11692 nfilb=nfilb-1
11693 END IF
11694#else
11695 WRITE(*,*) 'Opening of C-files not supported.'
11696 ! GF add
11697 iosum=iosum+1
11698 ! GF add end
11699#endif
11700 END IF
11701 ioff=ioff+lfd(i)
11702 END DO
11703
11704 DO k=1,nfilb
11705 kfd(1,k)=1 ! reset (negated) record counters
11706 kfd(2,k)=k ! set file number
11707 ifd(k)=0 ! reset integrated record numbers
11708 xfd(k)=0 ! reset max record size
11709 END DO
11710
11711 IF(iosum /= 0) THEN
11712 CALL peend(15,'Aborted, open error(s) for binary files')
11713 stop 'FILETC: open error '
11714 END IF
11715 IF(nfilb == 0) THEN
11716 CALL peend(14,'Aborted, no binary files')
11717 stop 'FILETC: no binary files '
11718 END IF
11719 IF (keepopen > 0) THEN
11720 WRITE(*,*) nfilb,' binary files opened' ! corrected by GF
11721 ELSE
11722 WRITE(*,*) nfilb,' binary files opened and closed' ! corrected by GF
11723 END IF
11724101 FORMAT(i3,2x,a)
11725102 FORMAT(a)
11726103 FORMAT(i3,2x,a14,3x,a)
11727 ! CALL mend
11728 RETURN
11729END SUBROUTINE filetc
11730
11781
11782SUBROUTINE filetx ! ---------------------------------------------------
11783 USE mpmod
11784
11785 IMPLICIT NONE
11786 INTEGER(mpi) :: i
11787 INTEGER(mpi) :: ia
11788 INTEGER(mpi) :: ib
11789 INTEGER(mpi) :: ierrf
11790 INTEGER(mpi) :: ioff
11791 INTEGER(mpi) :: ios
11792 INTEGER(mpi) :: iosum
11793 INTEGER(mpi) :: k
11794 INTEGER(mpi) :: mat
11795 INTEGER(mpi) :: nab
11796 INTEGER(mpi) :: nfiln
11797 INTEGER(mpi) :: nline
11798 INTEGER(mpi) :: nlinmx
11799 INTEGER(mpi) :: npat
11800 INTEGER(mpi) :: ntext
11801 INTEGER(mpi) :: matint
11802
11803 ! CALL MSTART('FILETX')
11804
11805 CHARACTER (LEN=1024) :: text
11806 CHARACTER (LEN=1024) :: fname
11807
11808 WRITE(*,*) ' '
11809 WRITE(*,*) 'Processing text files ...'
11810 WRITE(*,*) ' '
11811
11812 iosum=0
11813 ioff=0
11814 DO i=0,nfiles
11815 IF(i == 0) THEN
11816 WRITE(*,*) 'File ',filnam(1:nfnam)
11817 nlinmx=100
11818 ELSE
11819 nlinmx=10
11820 ia=ioff
11821 ioff=ioff+lfd(i)
11822 IF(mfd(i) /= 2) cycle ! exclude binary files
11823 DO k=1,lfd(i)
11824 fname(k:k)=tfd(ia+k)
11825 END DO
11826 WRITE(*,*) 'File ',fname(1:lfd(i))
11827 IF (mprint > 1) WRITE(*,*) ' '
11828 OPEN(10,file=fname(1:lfd(i)),iostat=ios,form='FORMATTED')
11829 IF(ios /= 0) THEN
11830 WRITE(*,*) 'Open error for file ',fname(1:lfd(i))
11831 iosum=iosum+1
11832 cycle
11833 END IF
11834 END IF
11835
11836 nline=0
11837 nfiln=1
11838 ! read text file
11839 DO
11840 READ(10,102,iostat=ierrf) text
11841 IF (ierrf < 0) THEN
11842 text=' '
11843 CALL intext(text,nline)
11844 WRITE(*,*) ' end-of-file after',nline,' text lines'
11845 EXIT ! eof
11846 ENDIF
11847 nline=nline+1
11848 IF(nline <= nlinmx.AND.mprint > 1) THEN ! print first 10 lines of every text fiLE
11849 CALL rltext(text,ia,ib,nab)
11850 nab=max(1,nab)
11851 WRITE(*,101) nline,text(1:nab)
11852 IF(nline == nlinmx) WRITE(*,*) ' ...'
11853 END IF
11854
11855 CALL rltext(text,ia,ib,nab) ! test content 'end'
11856 IF(ib == ia+2) THEN
11857 mat=matint(text(ia:ib),'end',npat,ntext)
11858 IF(mat == max(npat,ntext)) THEN ! exact matching
11859 text=' '
11860 CALL intext(text,nline)
11861 WRITE(*,*) ' end-statement after',nline,' text lines'
11862 EXIT
11863 END IF
11864 END IF
11865
11866 IF(i == 0) THEN ! first text file - exclude lines with file names
11867 IF(nfiln <= nfiles) THEN
11868 IF(nline == nfd(nfiln)) THEN
11869 nfiln=nfiln+1
11870 text=' '
11871 ! WRITE(*,*) 'line is excluded ',TEXT(1:10)
11872 END IF
11873 END IF
11874 END IF
11875 ! WRITE(*,*) TEXT(1:40),' < interprete text'
11876 CALL intext(text,nline) ! interprete text
11877 END DO
11878 WRITE(*,*) ' '
11879 rewind 10
11880 CLOSE(unit=10)
11881 END DO
11882
11883 IF(iosum /= 0) THEN
11884 CALL peend(16,'Aborted, open error(s) for text files')
11885 stop 'FILETX: open error(s) in text files '
11886 END IF
11887
11888 WRITE(*,*) '... end of text file processing.'
11889 WRITE(*,*) ' '
11890
11891 IF(lunkno /= 0) THEN
11892 WRITE(*,*) ' '
11893 WRITE(*,*) lunkno,' unknown keywords in steering files, ', &
11894 'or file non-existing,'
11895 WRITE(*,*) ' see above!'
11896 WRITE(*,*) '------------> stop'
11897 WRITE(*,*) ' '
11898 CALL peend(13,'Aborted, unknown keywords in steering file')
11899 stop
11900 END IF
11901
11902 ! check methods
11903
11904 IF(metsol == 0) THEN ! if undefined
11905 IF(matsto == 0) THEN ! if unpacked symmetric
11906 metsol=8 ! LAPACK
11907 ELSE IF(matsto == 1) THEN ! if full symmetric
11908 metsol=4 ! MINRES
11909 ELSE IF(matsto == 2) THEN ! if sparse
11910 metsol=4 ! MINRES
11911 END IF
11912 ELSE IF(metsol == 1) THEN ! if inversion
11913 matsto=1
11914 ELSE IF(metsol == 2) THEN ! if diagonalization
11915 matsto=1
11916 ELSE IF(metsol == 3) THEN ! if decomposition
11917 matsto=1
11918 ELSE IF(metsol == 4) THEN ! if MINRES
11919 ! MATSTO=2 or 1
11920 ELSE IF(metsol == 5) THEN ! if MINRES-QLP
11921 ! MATSTO=2 or 1
11922 ELSE IF(metsol == 6) THEN ! if GMRES
11923 ! MATSTO=2 or 1
11924#ifdef LAPACK64
11925 ELSE IF(metsol == 7) THEN ! if LAPACK
11926 matsto=1
11927 ELSE IF(metsol == 8) THEN ! if LAPACK
11928 matsto=0
11929#ifdef PARDISO
11930 ELSE IF(metsol == 9) THEN ! if Intel oneMKL PARDISO
11931 matsto=3
11932#endif
11933#endif
11934 ELSE
11935 WRITE(*,*) 'MINRES forced with sparse matrix!'
11936 WRITE(*,*) ' '
11937 WRITE(*,*) 'MINRES forced with sparse matrix!'
11938 WRITE(*,*) ' '
11939 WRITE(*,*) 'MINRES forced with sparse matrix!'
11940 metsol=4 ! forced
11941 matsto=2 ! forced
11942 END IF
11943 IF(matsto > 4) THEN
11944 WRITE(*,*) 'MINRES forced with sparse matrix!'
11945 WRITE(*,*) ' '
11946 WRITE(*,*) 'MINRES forced with sparse matrix!'
11947 WRITE(*,*) ' '
11948 WRITE(*,*) 'MINRES forced with sparse matrix!'
11949 metsol=4 ! forced
11950 matsto=2 ! forced
11951 END IF
11952
11953 ! print information about methods and matrix storage modes
11954
11955 WRITE(*,*) ' '
11956 WRITE(*,*) 'Solution method and matrix-storage mode:'
11957 IF(metsol == 1) THEN
11958 WRITE(*,*) ' METSOL = 1: matrix inversion'
11959 ELSE IF(metsol == 2) THEN
11960 WRITE(*,*) ' METSOL = 2: diagonalization'
11961 ELSE IF(metsol == 3) THEN
11962 WRITE(*,*) ' METSOL = 3: decomposition'
11963 ELSE IF(metsol == 4) THEN
11964 WRITE(*,*) ' METSOL = 4: MINRES'
11965 ELSE IF(metsol == 5) THEN
11966 WRITE(*,*) ' METSOL = 5: MINRES-QLP'
11967 ELSE IF(metsol == 6) THEN
11968 WRITE(*,*) ' METSOL = 6: GMRES (-> MINRES)'
11969#ifdef LAPACK64
11970 ELSE IF(metsol == 7) THEN
11971 WRITE(*,*) ' METSOL = 7: LAPACK factorization'
11972 ELSE IF(metsol == 8) THEN
11973 WRITE(*,*) ' METSOL = 8: LAPACK factorization'
11974#ifdef PARDISO
11975 ELSE IF(metsol == 9) THEN
11976 WRITE(*,*) ' METSOL = 9: Intel oneMKL PARDISO'
11977#endif
11978#endif
11979 END IF
11980
11981 WRITE(*,*) ' with',mitera,' iterations'
11982
11983 IF(matsto == 0) THEN
11984 WRITE(*,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
11985 ELSEIF(matsto == 1) THEN
11986 WRITE(*,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
11987 ELSE IF(matsto == 2) THEN
11988 WRITE(*,*) ' MATSTO = 2: sparse matrix (custom)'
11989 ELSE IF(matsto == 3) THEN
11990 IF (mpdbsz == 0) THEN
11991 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
11992 ELSE
11993 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
11994 END IF
11995 END IF
11996 IF(mbandw /= 0.AND.(metsol >= 4.AND. metsol <7)) THEN ! band matrix as MINRES preconditioner
11997 WRITE(*,*) ' and band matrix, width',mbandw
11998 END IF
11999
12000 IF(chicut /= 0.0) THEN
12001 WRITE(*,*) 'Chi square cut equiv 3 st.dev applied ...'
12002 WRITE(*,*) ' in first iteration with factor',chicut
12003 WRITE(*,*) ' in second iteration with factor',chirem
12004 WRITE(*,*) ' (reduced by sqrt in next iterations)'
12005 END IF
12006
12007 IF(lhuber /= 0) THEN
12008 WRITE(*,*) ' Down-weighting of outliers in', lhuber,' iterations'
12009 WRITE(*,*) ' Cut on downweight fraction',dwcut
12010 END IF
12011
12012 WRITE(*,*) 'Iterations (solutions) with line search:'
12013 IF(lsearch > 2) THEN
12014 WRITE(*,*) ' All'
12015 ELSEIF (lsearch == 1) THEN
12016 WRITE(*,*) ' Last'
12017 ELSEIF (lsearch < 1) THEN
12018 WRITE(*,*) ' None'
12019 ELSE
12020 IF (chicut /= 0.0) THEN
12021 WRITE(*,*) ' All with Chi square cut scaling factor <= 1.'
12022 ELSE
12023 WRITE(*,*) ' All'
12024 ENDIF
12025 ENDIF
12026
12027 IF(nummeasurements>0) THEN
12028 WRITE(*,*)
12029 WRITE(*,*) ' Number of external measurements ', nummeasurements
12030 ENDIF
12031
12032 CALL mend
12033
12034101 FORMAT(i3,2x,a)
12035102 FORMAT(a)
12036END SUBROUTINE filetx
12037
12047
12048INTEGER(mpi) FUNCTION nufile(fname)
12049 USE mpdef
12050
12051 IMPLICIT NONE
12052 INTEGER(mpi) :: ios
12053 INTEGER(mpi) :: l1
12054 INTEGER(mpi) :: ll
12055 INTEGER(mpi) :: nm
12056 INTEGER(mpi) :: npat
12057 INTEGER(mpi) :: ntext
12058 INTEGER(mpi) :: nuprae
12059 INTEGER(mpi) :: matint
12060
12061 CHARACTER (LEN=*), INTENT(INOUT) :: fname
12062 LOGICAL :: ex
12063 SAVE
12064 ! ...
12065 nufile=0
12066 nuprae=0
12067 IF(len(fname) > 5) THEN
12068 IF(fname(1:5) == 'rfio:') nuprae=1
12069 IF(fname(1:5) == 'dcap:') nuprae=2
12070 IF(fname(1:5) == 'root:') nuprae=3
12071 END IF
12072 IF(nuprae == 0) THEN
12073 INQUIRE(file=fname,iostat=ios,exist=ex)
12074 IF(ios /= 0) nufile=-abs(ios)
12075 IF(ios /= 0) RETURN
12076 ELSE IF(nuprae == 1) THEN ! rfio:
12077 ll=len(fname)
12078 fname=fname(6:ll)
12079 ex=.true.
12080 nufile=1
12081 RETURN
12082 ELSE
12083 ex=.true. ! assume file existence
12084 END IF
12085 IF(ex) THEN
12086 nufile=1 ! binary
12087 ll=len(fname)
12088 l1=max(1,ll-3)
12089 nm=matint('xt',fname(l1:ll),npat,ntext)
12090 IF(nm == 2) nufile=2 ! text
12091 IF(nm < 2) THEN
12092 nm=matint('tx',fname(l1:ll),npat,ntext)
12093 IF(nm == 2) nufile=2 ! text
12094 END IF
12095 END IF
12096END FUNCTION nufile
12097
12105SUBROUTINE intext(text,nline)
12106 USE mpmod
12107 USE mptext
12108
12109 IMPLICIT NONE
12110 INTEGER(mpi) :: i
12111 INTEGER(mpi) :: ia
12112 INTEGER(mpi) :: ib
12113 INTEGER(mpi) :: ier
12114 INTEGER(mpi) :: iomp
12115 INTEGER(mpi) :: j
12116 INTEGER(mpi) :: k
12117 INTEGER(mpi) :: kkey
12118 INTEGER(mpi) :: label
12119 INTEGER(mpi) :: lkey
12120 INTEGER(mpi) :: mat
12121 INTEGER(mpi) :: miter
12122 INTEGER(mpi) :: nab
12123 INTEGER(mpi) :: nkey
12124 INTEGER(mpi) :: nkeys
12125 INTEGER(mpi) :: nl
12126 INTEGER(mpi) :: nmeth
12127 INTEGER(mpi) :: npat
12128 INTEGER(mpi) :: ntext
12129 INTEGER(mpi) :: nums
12130 INTEGER(mpi) :: matint
12131
12132 CHARACTER (LEN=*), INTENT(IN) :: text
12133 INTEGER(mpi), INTENT(IN) :: nline
12134
12135#ifdef LAPACK64
12136#ifdef PARDISO
12137 parameter(nkeys=7,nmeth=10)
12138#else
12139 parameter(nkeys=6,nmeth=9)
12140#endif
12141#else
12142 parameter(nkeys=6,nmeth=7)
12143#endif
12144 CHARACTER (LEN=16) :: methxt(nmeth)
12145 CHARACTER (LEN=16) :: keylst(nkeys)
12146 CHARACTER (LEN=32) :: keywrd
12147 CHARACTER (LEN=32) :: keystx
12148 CHARACTER (LEN=itemCLen) :: ctext
12149 INTEGER(mpi), PARAMETER :: mnum=100
12150 REAL(mpd) :: dnum(mnum)
12151#ifdef LAPACK64
12152#ifdef PARDISO
12153 INTEGER(mpi) :: ipvs ! ... integer value
12154#endif
12155#endif
12156 INTEGER(mpi) :: lpvs ! ... integer label
12157 REAL(mpd) :: plvs ! ... float value
12158
12159 INTERFACE
12160 SUBROUTINE additem(length,list,label,value)
12161 USE mpmod
12162 INTEGER(mpi), INTENT(IN OUT) :: length
12163 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12164 INTEGER(mpi), INTENT(IN) :: label
12165 REAL(mpd), INTENT(IN) :: value
12166 END SUBROUTINE additem
12167 SUBROUTINE additemc(length,list,label,text)
12168 USE mpmod
12169 INTEGER(mpi), INTENT(IN OUT) :: length
12170 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12171 INTEGER(mpi), INTENT(IN) :: label
12172 CHARACTER(LEN = itemCLen), INTENT(IN) :: text
12173 END SUBROUTINE additemc
12174 SUBROUTINE additemi(length,list,label,ivalue)
12175 USE mpmod
12176 INTEGER(mpi), INTENT(IN OUT) :: length
12177 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12178 INTEGER(mpi), INTENT(IN) :: label
12179 INTEGER(mpi), INTENT(IN) :: ivalue
12180 END SUBROUTINE additemi
12181 END INTERFACE
12182
12183 SAVE
12184#ifdef LAPACK64
12185#ifdef PARDISO
12186 DATA keylst/'unknown','parameter','constraint','measurement','method','comment','pardiso'/
12187 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12188 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK', &
12189 'sparsePARDISO'/
12190#else
12191 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
12192 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12193 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK'/
12194#endif
12195#else
12196 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
12197 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12198 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition'/
12199#endif
12200 DATA lkey/-1/ ! last keyword
12201
12202 ! ...
12203 nkey=-1 ! new keyword
12204 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
12205 IF(nab == 0) GOTO 10
12206 CALL ratext(text(1:nab),nums,dnum,mnum) ! translate text to DP numbers
12207
12208 IF(nums /= 0) nkey=0
12209 IF(keyb /= 0) THEN
12210 keywrd=text(keya:keyb) ! text is TEXT(KEYA)...TEXT(KEYB)
12211 ! WRITE(*,*) 'Keyword is ',KEYWRD
12212
12213 ! compare keywords
12214
12215 DO nkey=2,nkeys ! loop over all pede keywords
12216 keystx=keylst(nkey) ! copy NKEY.th pede keyword
12217 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12218 IF(100*mat >= 80*max(npat,ntext)) GO TO 10 ! 80% (symmetric) matching
12219 END DO
12220
12221 ! more comparisons
12222
12223 keystx='print'
12224 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12225 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12226 mprint=1
12227 IF(nums > 0) mprint=nint(dnum(1),mpi)
12228 RETURN
12229 END IF
12230
12231 keystx='debug'
12232 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12233 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12234 mdebug=3
12235 ! GF IF(NUMS.GT.0) MPRINT=DNUM(1)
12236 IF(nums > 0) mdebug=nint(dnum(1),mpi)
12237 IF(nums > 1) mdebg2=nint(dnum(2),mpi)
12238 RETURN
12239 END IF
12240
12241 keystx='entries'
12242 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12243 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12244 IF(nums > 0 .AND. dnum(1) > 0.5) mreqenf=nint(dnum(1),mpi)
12245 IF(nums > 1 .AND. dnum(2) > 0.5) mreqena=nint(dnum(2),mpi)
12246 IF(nums > 2 .AND. dnum(3) > 0.5) iteren=nint(dnum(1)*dnum(3),mpi)
12247 RETURN
12248 END IF
12249
12250 keystx='printrecord'
12251 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12252 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12253 IF(nums > 0) nrecpr=nint(dnum(1),mpi)
12254 IF(nums > 1) nrecp2=nint(dnum(2),mpi)
12255 RETURN
12256 END IF
12257
12258 keystx='maxrecord'
12259 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12260 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12261 IF (nums > 0.AND.dnum(1) > 0.) mxrec=nint(dnum(1),mpi)
12262 RETURN
12263 END IF
12264
12265 keystx='cache'
12266 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12267 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12268 IF (nums > 0.AND.dnum(1) >= 0.) ncache=nint(dnum(1),mpi) ! cache size, <0 keeps default
12269 IF (nums == 2.AND.dnum(2) > 0..AND.dnum(2) <= 1.0) & ! read cache fill level
12270 fcache(1)=real(dnum(2),mps)
12271 IF (nums >= 4) THEN ! explicit cache splitting
12272 DO k=1,3
12273 fcache(k)=real(dnum(k+1),mps)
12274 END DO
12275 END IF
12276 RETURN
12277 END IF
12278
12279 keystx='chisqcut'
12280 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12281 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12282 IF(nums == 0) THEN ! always 3-sigma cut
12283 chicut=1.0
12284 chirem=1.0
12285 ELSE
12286 chicut=real(dnum(1),mps)
12287 IF(chicut < 1.0) chicut=-1.0
12288 IF(nums == 1) THEN
12289 chirem=1.0 ! 3-sigma cut, if not specified
12290 ELSE
12291 chirem=real(dnum(2),mps)
12292 IF(chirem < 1.0) chirem=1.0
12293 IF(chicut >= 1.0) chirem=min(chirem,chicut)
12294 END IF
12295 END IF
12296 RETURN
12297 END IF
12298
12299 ! GF added:
12300 keystx='hugecut'
12301 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12302 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12303 IF(nums > 0) chhuge=real(dnum(1),mps)
12304 IF(chhuge < 1.0) chhuge=1.0 ! at least (!!) 3-sigma
12305 RETURN
12306 END IF
12307 ! GF added end
12308
12309 keystx='linesearch'
12310 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12311 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12312 IF(nums > 0) lsearch=nint(dnum(1),mpi)
12313 RETURN
12314 END IF
12315
12316 keystx='localfit'
12317 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12318 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12319 IF(nums > 0) lfitnp=nint(dnum(1),mpi)
12320 IF(nums > 1) lfitbb=nint(dnum(2),mpi)
12321 RETURN
12322 END IF
12323
12324 keystx='regularization'
12325 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12326 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12327 nregul=1
12328 regula=real(dnum(1),mps)
12329 IF(nums >= 2) regpre=real(dnum(2),mps)
12330 RETURN
12331 END IF
12332
12333 keystx='regularisation'
12334 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12335 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12336 nregul=1
12337 regula=real(dnum(1),mps)
12338 IF(nums >= 2) regpre=real(dnum(2),mps)
12339 RETURN
12340 END IF
12341
12342 keystx='presigma'
12343 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12344 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12345 regpre=real(dnum(1),mps)
12346 RETURN
12347 END IF
12348
12349 keystx='matiter'
12350 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12351 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12352 matrit=nint(dnum(1),mpi)
12353 RETURN
12354 END IF
12355
12356 keystx='matmoni'
12357 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12358 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12359 matmon=-1
12360 IF (nums > 0.AND.dnum(1) > 0.) matmon=nint(dnum(1),mpi)
12361 RETURN
12362 END IF
12363
12364 keystx='bandwidth'
12365 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12366 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12367 IF(nums > 0) mbandw=nint(dnum(1),mpi)
12368 IF(mbandw < 0) mbandw=-1
12369 IF(nums > 1) lprecm=nint(dnum(2),mpi)
12370 RETURN
12371 END IF
12372
12373 ! KEYSTX='outlierrejection'
12374 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12375 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12376 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12377 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12378 ! CHDFRJ=DNUM(1)
12379 ! IF(CHDFRJ.LT.3.0) CHDFRJ=100.0
12380 ! RETURN
12381 ! END IF
12382
12383 ! KEYSTX='outliersuppression'
12384 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12385 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12386 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12387 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12388 ! LHUBER=DNUM(1)
12389 ! IF(LHUBER.LE.2) LHUBER=2 ! at least 2 Huber iterations
12390 ! RETURN
12391 ! END IF
12392
12393 keystx='outlierdownweighting'
12394 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12395 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12396 lhuber=nint(dnum(1),mpi)
12397 IF(lhuber > 0.AND.lhuber <= 2) lhuber=2 ! at least 2 Huber iterations (if any)
12398 RETURN
12399 END IF
12400
12401 keystx='dwfractioncut'
12402 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12403 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12404 dwcut=real(dnum(1),mps)
12405 IF(dwcut > 0.5) dwcut=0.5
12406 RETURN
12407 END IF
12408
12409 keystx='maxlocalcond'
12410 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12411 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12412 IF (nums > 0.AND.dnum(1) > 0.0) cndlmx=real(dnum(1),mps)
12413 RETURN
12414 END IF
12415
12416 keystx='pullrange'
12417 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12418 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12419 prange=abs(real(dnum(1),mps))
12420 RETURN
12421 END IF
12422
12423 keystx='subito'
12424 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12425 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12426 isubit=1
12427 RETURN
12428 END IF
12429
12430 keystx='force'
12431 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12432 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12433 iforce=1
12434 RETURN
12435 END IF
12436
12437 keystx='memorydebug'
12438 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12439 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12440 memdbg=1
12441 IF (nums > 0.AND.dnum(1) > 0.0) memdbg=nint(dnum(1),mpi)
12442 RETURN
12443 END IF
12444
12445 keystx='globalcorr'
12446 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12447 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12448 igcorr=1
12449 RETURN
12450 END IF
12451
12452 keystx='printcounts'
12453 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12454 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12455 ipcntr=1
12456 IF (nums > 0) ipcntr=nint(dnum(1),mpi)
12457 RETURN
12458 END IF
12459
12460 keystx='weightedcons'
12461 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12462 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12463 iwcons=1
12464 IF (nums > 0) iwcons=nint(dnum(1),mpi)
12465 RETURN
12466 END IF
12467
12468 keystx='skipemptycons'
12469 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12470 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12471 iskpec=1
12472 RETURN
12473 END IF
12474
12475 keystx='resolveredundancycons'
12476 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12477 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12478 irslvrc=1
12479 RETURN
12480 END IF
12481
12482 keystx='withelimination'
12483 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12484 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12485 icelim=1
12486 RETURN
12487 END IF
12488
12489 keystx='postprocessing'
12490 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12491 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12492 lenpostproc=ib-keyb-1
12493 cpostproc(1:lenpostproc)=text(keyb+2:ib)
12494 RETURN
12495 END IF
12496
12497#ifdef LAPACK64
12498 keystx='withLAPACKelimination'
12499 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12500 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12501 icelim=2
12502 RETURN
12503 END IF
12504#endif
12505
12506 keystx='withmultipliers'
12507 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12508 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12509 icelim=0
12510 RETURN
12511 END IF
12512
12513 keystx='checkinput'
12514 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12515 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12516 icheck=1
12517 IF (nums > 0) icheck=nint(dnum(1),mpi)
12518 RETURN
12519 END IF
12520
12521 keystx='checkparametergroups'
12522 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12523 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12524 ichkpg=1
12525 RETURN
12526 END IF
12527
12528 keystx='monitorresiduals'
12529 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12530 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12531 imonit=3
12532 IF (nums > 0) imonit=nint(dnum(1),mpi)
12533 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12534 RETURN
12535 END IF
12536
12537 keystx='monitorpulls'
12538 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12539 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12540 imonit=3
12541 imonmd=1
12542 IF (nums > 0) imonit=nint(dnum(1),mpi)
12543 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12544 RETURN
12545 END IF
12546
12547 keystx='monitorprogress'
12548 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12549 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12550 monpg1=1
12551 monpg2=1024
12552 IF (nums > 0) monpg1=max(1,nint(dnum(1),mpi))
12553 IF (nums > 1) monpg2=max(1,nint(dnum(2),mpi))
12554 RETURN
12555 END IF
12556
12557 keystx='scaleerrors'
12558 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12559 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12560 iscerr=1
12561 IF (nums > 0) dscerr(1:2)=dnum(1)
12562 IF (nums > 1) dscerr(2)=dnum(2)
12563 RETURN
12564 END IF
12565
12566 keystx='iterateentries'
12567 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12568 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12569 iteren=huge(iteren)
12570 IF (nums > 0) iteren=nint(dnum(1),mpi)
12571 RETURN
12572 END IF
12573
12574 keystx='threads'
12575 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12576 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12577 iomp=0
12578 !$ IOMP=1
12579 !$ IF (IOMP.GT.0) THEN
12580 !$ IF (NUMS.GE.1.AND.DNUM(1).GT.0.) MTHRD =NINT(dnum(1),mpi)
12581 !$ MTHRDR=MTHRD
12582 !$ IF (NUMS.GE.2.AND.DNUM(2).GT.0.) MTHRDR=NINT(dnum(2),mpi)
12583 !$ ELSE
12584 WRITE(*,*) 'WARNING: multithreading not available'
12585 !$ ENDIF
12586 RETURN
12587 END IF
12588
12589 keystx='compress'
12590 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12591 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12592 WRITE(*,*) 'WARNING: keyword COMPRESS is obsolete (compression is default)'
12593 RETURN
12594 END IF
12595
12596 ! still experimental
12597 !keystx='extendedStorage'
12598 !mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12599 !IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12600 ! mextnd=1
12601 ! RETURN
12602 !END IF
12603
12604 keystx='countrecords'
12605 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12606 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12607 mcount=1
12608 RETURN
12609 END IF
12610
12611 keystx='errlabels'
12612 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12613 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12614 nl=min(nums,100-mnrsel)
12615 DO k=1,nl
12616 lbmnrs(mnrsel+k)=nint(dnum(k),mpi)
12617 END DO
12618 mnrsel=mnrsel+nl
12619 RETURN
12620 END IF
12621
12622 keystx='pairentries'
12623 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12624 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12625 ! This option could be implemented to get rid of parameter pairs
12626 ! that have very few entries - to save matrix memory size.
12627 IF (nums > 0.AND.dnum(1) > 0.0) THEN
12628 mreqpe=nint(dnum(1),mpi)
12629 IF (nums >= 2.AND.dnum(2) >= dnum(1)) mhispe=nint(dnum(2),mpi)
12630 IF (nums >= 3.AND.dnum(3) >= dnum(1)) msngpe=nint(dnum(3),mpi)
12631 END IF
12632 RETURN
12633 END IF
12634
12635 keystx='wolfe'
12636 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12637 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12638 wolfc1=real(dnum(1),mps)
12639 wolfc2=real(dnum(2),mps)
12640 RETURN
12641 END IF
12642
12643 ! GF added:
12644 ! convergence tolerance for minres:
12645 keystx='mrestol'
12646 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12647 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12648 IF(nums > 0) THEN
12649 IF (dnum(1) < 1.0e-10_mpd.OR.dnum(1) > 1.0e-04_mpd) THEN
12650 WRITE(*,*) 'ERROR: need 1.0D-10 <= MRESTL ', &
12651 '<= 1.0D-04, but get ', dnum(1)
12652 ELSE
12653 mrestl=dnum(1)
12654 END IF
12655 END IF
12656 RETURN
12657 END IF
12658 ! GF added end
12659
12660 keystx='mrestranscond'
12661 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12662 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12663 IF(nums > 0) THEN
12664 mrtcnd = dnum(1)
12665 END IF
12666 RETURN
12667 END IF
12668
12669 keystx='mresmode'
12670 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12671 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12672 IF(nums > 0) THEN
12673 mrmode = int(dnum(1),mpi)
12674 END IF
12675 RETURN
12676 END IF
12677
12678 keystx='nofeasiblestart'
12679 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12680 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12681 nofeas=1 ! do not make parameters feasible at start
12682 RETURN
12683 END IF
12684
12685 keystx='histprint'
12686 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12687 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12688 nhistp=1 ! print histograms
12689 RETURN
12690 END IF
12691
12692 keystx='readerroraseof' ! treat (C) read errors as eof
12693 mat=matint(text(ia:ib),keystx,npat,ntext)
12694 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12695 ireeof=1
12696 RETURN
12697 END IF
12698
12699#ifdef LAPACK64
12700 keystx='LAPACKwitherrors' ! calculate parameter errors with LAPACK
12701 mat=matint(text(ia:ib),keystx,npat,ntext)
12702 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12703 ilperr=1
12704 RETURN
12705 END IF
12706#ifdef PARDISO
12707 keystx='debugPARDISO' ! enable debug for Intel oneMKL PARDISO
12708 mat=matint(text(ia:ib),keystx,npat,ntext)
12709 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12710 ipddbg=1
12711 RETURN
12712 END IF
12713
12714 keystx='blocksizePARDISO' ! use BSR3 for Intel oneMKL PARDISO, list of (increasing) block sizes to be tried
12715 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12716 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12717 nl=min(nums,10-mpdbsz)
12718 DO k=1,nl
12719 IF (nint(dnum(k),mpi) > 0) THEN
12720 IF (mpdbsz == 0) THEN
12721 mpdbsz=mpdbsz+1
12722 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12723 ELSE IF (nint(dnum(k),mpi) > ipdbsz(mpdbsz)) THEN
12724 mpdbsz=mpdbsz+1
12725 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12726 END IF
12727 END IF
12728 END DO
12729 RETURN
12730 END IF
12731#endif
12732#endif
12733 keystx='fortranfiles'
12734 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12735 IF(mat == max(npat,ntext)) RETURN
12736
12737 keystx='Cfiles'
12738 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12739 IF(mat == max(npat,ntext)) RETURN
12740
12741 keystx='closeandreopen'
12742 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12743 IF(mat == max(npat,ntext)) RETURN
12744
12745 keystx=keylst(1)
12746 nkey=1 ! unknown keyword
12747 IF(nums /= 0) nkey=0
12748
12749 WRITE(*,*) ' '
12750 WRITE(*,*) '**************************************************'
12751 WRITE(*,*) ' '
12752 WRITE(*,*) 'Unknown keyword(s): ',text(1:min(nab,50))
12753 WRITE(*,*) ' '
12754 WRITE(*,*) '**************************************************'
12755 WRITE(*,*) ' '
12756 lunkno=lunkno+1
12757
12758 END IF
12759 ! result: NKEY = -1 blank
12760 ! NKEY = 0 numerical data, no text keyword or unknown
12761 ! NKEY > 0 keyword NKEY from list, keyword = KEYSTX
12762
12763
12764 ! content/lastcontent
12765 ! -------------------
12766 ! blank -1
12767 ! data 0
12768 ! keyword
12769 ! unknown 1
12770 ! parameter 2
12771 ! constraint 3
12772 ! measurement 4
12773 ! method 5
12774
12775
1277610 IF(nkey > 0) THEN ! new keyword
12777 lkey=nkey
12778 IF(lkey == 2) THEN ! parameter
12779 IF(nums == 3) THEN
12780 lpvs=nint(dnum(1),mpi) ! label
12781 IF(lpvs /= 0) THEN
12782 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12783 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12784 ELSE
12785 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12786 END IF
12787 ELSE IF(nums /= 0) THEN
12788 kkey=1 ! switch to "unknown" ?
12789 WRITE(*,*) 'Wrong text in line',nline
12790 WRITE(*,*) 'Status: new parameter'
12791 WRITE(*,*) '> ',text(1:nab)
12792 END IF
12793 ELSE IF(lkey == 3) THEN ! constraint
12794 ! WRITE(*,*) 'Keyword is constraint!',NUMS,' numerical data'
12795 IF(nums >= 1.AND.nums <= 2) THEN ! start constraint
12796 lpvs=-nline ! r = r.h.s. value
12797 CALL additem(lenconstraints,listconstraints,lpvs,dnum(1))
12798 lpvs=-1 ! constraint
12799 IF(iwcons > 0) lpvs=-2 ! weighted constraint
12800 plvs=0.0
12801 IF(nums == 2) plvs=dnum(2) ! sigma
12802 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12803 ELSE
12804 kkey=1 ! switch to "unknown"
12805 WRITE(*,*) 'Wrong text in line',nline
12806 WRITE(*,*) 'Status: new keyword constraint'
12807 WRITE(*,*) '> ',text(1:nab)
12808 END IF
12809 ELSE IF(lkey == 4) THEN ! measurement
12810 IF(nums == 2) THEN ! start measurement
12811 nummeasurements=nummeasurements+1
12812 lpvs=-nline ! r = r.h.s. value
12813 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(1))
12814 lpvs=-1 ! sigma
12815 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(2))
12816 ELSE
12817 kkey=1 ! switch to "unknown"
12818 WRITE(*,*) 'Wrong text in line',nline
12819 WRITE(*,*) 'Status: new keyword measurement'
12820 WRITE(*,*) '> ',text(1:nab)
12821 END IF
12822 ELSE IF(lkey == 5.AND.keyb < keyc) THEN ! method with text argument
12823 miter=mitera
12824 IF(nums >= 1) miter=nint(dnum(1),mpi)
12825 IF(miter >= 1) mitera=miter
12826 dflim=real(dnum(2),mps)
12827 lkey=0
12828 DO i=1,nmeth
12829 keystx=methxt(i)
12830 mat=matint(text(keyb+1:keyc),keystx,npat,ntext) ! comparison
12831 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12832 IF(i == 1) THEN ! diagonalization
12833 metsol=2
12834 matsto=1
12835 ELSE IF(i == 2) THEN ! inversion
12836 metsol=1
12837 matsto=1
12838 ELSE IF(i == 3) THEN ! fullMINRES
12839 metsol=4
12840 matsto=1
12841 ELSE IF(i == 4) THEN ! sparseMINRES
12842 metsol=4
12843 matsto=2
12844 ELSE IF(i == 5) THEN ! fullMINRES-QLP
12845 metsol=5
12846 matsto=1
12847 ELSE IF(i == 6) THEN ! sparseMINRES-QLP
12848 metsol=5
12849 matsto=2
12850 ELSE IF(i == 7) THEN ! decomposition
12851 metsol=3
12852 matsto=1
12853#ifdef LAPACK64
12854 ELSE IF(i == 8) THEN ! fullLAPACK factorization
12855 metsol=7
12856 matsto=1
12857 ELSE IF(i == 9) THEN ! unpackedLAPACK factorization
12858 metsol=8
12859 matsto=0
12860#ifdef PARDISO
12861 ELSE IF(i == 10) THEN ! Intel oneMKL PARDISO (sparse matrix (CSR3 or BSR3, upper triangle))
12862 metsol=9
12863 matsto=3
12864#endif
12865#endif
12866 END IF
12867 END IF
12868 END DO
12869 END IF
12870 ELSE IF(nkey == 0) THEN ! data for continuation
12871 IF(lkey == 2) THEN ! parameter
12872 IF(nums >= 3) THEN ! store data from this line
12873 lpvs=nint(dnum(1),mpi) ! label
12874 IF(lpvs /= 0) THEN
12875 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12876 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12877 ELSE
12878 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12879 END IF
12880 ELSE IF(nums > 1.AND.nums < 3) THEN
12881 kkey=1 ! switch to "unknown" ?
12882 WRITE(*,*) 'Wrong text in line',nline
12883 WRITE(*,*) 'Status continuation parameter'
12884 WRITE(*,*) '> ',text(1:nab)
12885 END IF
12886
12887 ELSE IF(lkey == 3) THEN ! constraint
12888 ier=0
12889 DO i=1,nums,2
12890 label=nint(dnum(i),mpi)
12891 IF(label <= 0) ier=1
12892 END DO
12893 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12894 IF(ier == 0) THEN
12895 DO i=1,nums,2
12896 lpvs=nint(dnum(i),mpi) ! label
12897 plvs=dnum(i+1) ! factor
12898 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12899 END DO
12900 ELSE
12901 kkey=0
12902 WRITE(*,*) 'Wrong text in line',nline
12903 WRITE(*,*) 'Status continuation constraint'
12904 WRITE(*,*) '> ',text(1:nab)
12905 END IF
12906
12907 ELSE IF(lkey == 4) THEN ! measurement
12908 ! WRITE(*,*) 'continuation < ',NUMS
12909 ier=0
12910 DO i=1,nums,2
12911 label=nint(dnum(i),mpi)
12912 IF(label <= 0) ier=1
12913 END DO
12914 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12915 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12916 IF(ier == 0) THEN
12917 DO i=1,nums,2
12918 lpvs=nint(dnum(i),mpi) ! label
12919 plvs=dnum(i+1) ! factor
12920 CALL additem(lenmeasurements,listmeasurements,lpvs,plvs)
12921 END DO
12922 ELSE
12923 kkey=0
12924 WRITE(*,*) 'Wrong text in line',nline
12925 WRITE(*,*) 'Status continuation measurement'
12926 WRITE(*,*) '> ',text(1:nab)
12927 END IF
12928 ELSE IF(lkey == 6) THEN ! comment
12929 IF(nums == 1) THEN
12930 lpvs=nint(dnum(1),mpi) ! label
12931 IF(lpvs /= 0) THEN
12932 ! skip label
12933 DO j=ia,ib
12934 IF (text(j:j) == ' ') EXIT
12935 END DO
12936 ctext=text(j:ib)
12937 CALL additemc(lencomments,listcomments,lpvs,ctext)
12938 ELSE
12939 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12940 END IF
12941 ELSE IF(nums /= 0) THEN
12942 kkey=1 ! switch to "unknown"
12943 WRITE(*,*) 'Wrong text in line',nline
12944 WRITE(*,*) 'Status: continuation comment'
12945 WRITE(*,*) '> ',text(1:nab)
12946 END IF
12947#ifdef LAPACK64
12948#ifdef PARDISO
12949 ELSE IF(lkey == 7) THEN ! Intel oneMKL PARDISO parameters
12950 ier=0
12951 DO i=1,nums,2
12952 label=nint(dnum(i),mpi)
12953 IF(label <= 0.OR.label > 64) ier=1
12954 END DO
12955 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12956 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12957 IF(ier == 0) THEN
12958 DO i=1,nums,2
12959 lpvs=nint(dnum(i),mpi) ! label
12960 ipvs=nint(dnum(i+1),mpi) ! parameter
12961 CALL additemi(lenpardiso,listpardiso,lpvs,ipvs)
12962 END DO
12963 ELSE
12964 kkey=0
12965 WRITE(*,*) 'Wrong text in line',nline
12966 WRITE(*,*) 'Status continuation measurement'
12967 WRITE(*,*) '> ',text(1:nab)
12968 END IF
12969#endif
12970#endif
12971 END IF
12972 END IF
12973END SUBROUTINE intext
12974
12982SUBROUTINE additem(length,list,label,value)
12983 USE mpdef
12984 USE mpdalc
12985
12986 INTEGER(mpi), INTENT(IN OUT) :: length
12987 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12988 INTEGER(mpi), INTENT(IN) :: label
12989 REAL(mpd), INTENT(IN) :: value
12990
12991 INTEGER(mpl) :: newSize
12992 INTEGER(mpl) :: oldSize
12993 TYPE(listitem), DIMENSION(:), ALLOCATABLE :: tempList
12994
12995 IF (label > 0.AND.value == 0.) RETURN ! skip zero for valid labels
12996 IF (length == 0 ) THEN ! initial list with size = 100
12997 newsize = 100
12998 CALL mpalloc(list,newsize,' list ')
12999 ENDIF
13000 oldsize=size(list,kind=mpl)
13001 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
13002 newsize = oldsize + oldsize/5 + 100
13003 CALL mpalloc(templist,oldsize,' temp. list ')
13004 templist=list
13005 CALL mpdealloc(list)
13006 CALL mpalloc(list,newsize,' list ')
13007 list(1:oldsize)=templist(1:oldsize)
13008 CALL mpdealloc(templist)
13009 ENDIF
13010 ! add to end of list
13011 length=length+1
13012 list(length)%label=label
13013 list(length)%value=value
13014
13015END SUBROUTINE additem
13016
13024SUBROUTINE additemc(length,list,label,text)
13025 USE mpdef
13026 USE mpdalc
13027
13028 INTEGER(mpi), INTENT(IN OUT) :: length
13029 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
13030 INTEGER(mpi), INTENT(IN) :: label
13031 CHARACTER(len = itemCLen), INTENT(IN) :: text
13032
13033 INTEGER(mpl) :: newSize
13034 INTEGER(mpl) :: oldSize
13035 TYPE(listitemc), DIMENSION(:), ALLOCATABLE :: tempList
13036
13037 IF (label > 0.AND.text == '') RETURN ! skip empty text for valid labels
13038 IF (length == 0 ) THEN ! initial list with size = 100
13039 newsize = 100
13040 CALL mpalloc(list,newsize,' list ')
13041 ENDIF
13042 oldsize=size(list,kind=mpl)
13043 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
13044 newsize = oldsize + oldsize/5 + 100
13045 CALL mpalloc(templist,oldsize,' temp. list ')
13046 templist=list
13047 CALL mpdealloc(list)
13048 CALL mpalloc(list,newsize,' list ')
13049 list(1:oldsize)=templist(1:oldsize)
13050 CALL mpdealloc(templist)
13051 ENDIF
13052 ! add to end of list
13053 length=length+1
13054 list(length)%label=label
13055 list(length)%text=text
13056
13057END SUBROUTINE additemc
13058
13066SUBROUTINE additemi(length,list,label,ivalue)
13067 USE mpdef
13068 USE mpdalc
13069
13070 INTEGER(mpi), INTENT(IN OUT) :: length
13071 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
13072 INTEGER(mpi), INTENT(IN) :: label
13073 INTEGER(mpi), INTENT(IN) :: ivalue
13074
13075 INTEGER(mpl) :: newSize
13076 INTEGER(mpl) :: oldSize
13077 TYPE(listitemi), DIMENSION(:), ALLOCATABLE :: tempList
13078
13079 IF (length == 0 ) THEN ! initial list with size = 100
13080 newsize = 100
13081 CALL mpalloc(list,newsize,' list ')
13082 ENDIF
13083 oldsize=size(list,kind=mpl)
13084 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
13085 newsize = oldsize + oldsize/5 + 100
13086 CALL mpalloc(templist,oldsize,' temp. list ')
13087 templist=list
13088 CALL mpdealloc(list)
13089 CALL mpalloc(list,newsize,' list ')
13090 list(1:oldsize)=templist(1:oldsize)
13091 CALL mpdealloc(templist)
13092 ENDIF
13093 ! add to end of list
13094 length=length+1
13095 list(length)%label=label
13096 list(length)%ivalue=ivalue
13097
13098END SUBROUTINE additemi
13099
13101SUBROUTINE mstart(text)
13102 USE mpdef
13103 USE mpmod, ONLY: textl
13104
13105 IMPLICIT NONE
13106 INTEGER(mpi) :: i
13107 INTEGER(mpi) :: ka
13108 INTEGER(mpi) :: kb
13109 INTEGER(mpi) :: l
13110 CHARACTER (LEN=*), INTENT(IN) :: text
13111 CHARACTER (LEN=16) :: textc
13112 SAVE
13113 ! ...
13114 DO i=1,74
13115 textl(i:i)='_'
13116 END DO
13117 l=len(text)
13118 ka=(74-l)/2
13119 kb=ka+l-1
13120 textl(ka:kb)=text(1:l)
13121 WRITE(*,*) ' '
13122 WRITE(*,*) textl
13123 WRITE(*,*) ' '
13124 textc=text(1:l)//'-end'
13125
13126 DO i=1,74
13127 textl(i:i)='_'
13128 END DO
13129 l=l+4
13130 ka=(74-l)/2
13131 kb=ka+l-1
13132 textl(ka:kb)=textc(1:l)
13133 RETURN
13134END SUBROUTINE mstart
13135
13137SUBROUTINE mend
13138 USE mpmod, ONLY: textl
13139
13140 IMPLICIT NONE
13141 WRITE(*,*) ' '
13142 WRITE(*,*) textl
13143 CALL petime
13144 WRITE(*,*) ' '
13145END SUBROUTINE mend
13146
13153
13154SUBROUTINE mvopen(lun,fname)
13155 USE mpdef
13156
13157 IMPLICIT NONE
13158 INTEGER(mpi) :: l
13159 INTEGER(mpi), INTENT(IN) :: lun
13160 CHARACTER (LEN=*), INTENT(IN) :: fname
13161 CHARACTER (LEN=33) :: nafile
13162 CHARACTER (LEN=33) :: nbfile
13163 LOGICAL :: ex
13164 SAVE
13165 ! ...
13166 l=len(fname)
13167 IF(l > 32) THEN
13168 CALL peend(17,'Aborted, file name too long')
13169 stop 'File name too long '
13170 END IF
13171 nafile=fname
13172 nafile(l+1:l+1)='~'
13173
13174 INQUIRE(file=nafile(1:l),exist=ex)
13175 IF(ex) THEN
13176 INQUIRE(file=nafile(1:l+1),exist=ex)
13177 IF(ex) THEN
13178 CALL system('rm '//nafile)
13179 END IF
13180 nbfile=nafile
13181 nafile(l+1:l+1)=' '
13182 CALL system('mv '//nafile//nbfile)
13183 END IF
13184 OPEN(unit=lun,file=fname)
13185END SUBROUTINE mvopen
13186
13190
13191SUBROUTINE petime
13192 USE mpdef
13193
13194 IMPLICIT NONE
13195 REAL, DIMENSION(2) :: ta
13196 REAL etime
13197 REAL :: rst
13198 REAL :: delta
13199 REAL :: rstp
13200 REAL :: secnd1
13201 REAL :: secnd2
13202 INTEGER :: ncount
13203 INTEGER :: nhour1
13204 INTEGER :: minut1
13205 INTEGER :: nsecd1
13206 INTEGER :: nhour2
13207 INTEGER :: minut2
13208 INTEGER :: nsecd2
13209
13210 SAVE
13211 DATA ncount/0/
13212 ! ...
13213 ncount=ncount+1
13214 rst=etime(ta)
13215 IF(ncount > 1) THEN
13216 delta=rst
13217 nsecd1=int(delta,mpi) ! -> integer
13218 nhour1=nsecd1/3600
13219 minut1=nsecd1/60-60*nhour1
13220 secnd1=delta-60*(minut1+60*nhour1)
13221 delta=rst-rstp
13222 nsecd2=int(delta,mpi) ! -> integer
13223 nhour2=nsecd2/3600
13224 minut2=nsecd2/60-60*nhour2
13225 secnd2=delta-60*(minut2+60*nhour2)
13226 WRITE(*,101) nhour1,minut1,secnd1, nhour2,minut2,secnd2
13227 END IF
13228
13229 rstp=rst
13230 RETURN
13231101 FORMAT(i4,' h',i3,' min',f5.1,' sec total',18x,'elapsed', &
13232 i4,' h',i3,' min',f5.1,' sec')
13233END SUBROUTINE petime ! print
13234
13241
13242SUBROUTINE peend(icode, cmessage)
13243 USE mpdef
13244
13245 IMPLICIT NONE
13246 INTEGER(mpi), INTENT(IN) :: icode
13247 CHARACTER (LEN=*), INTENT(IN) :: cmessage
13248
13249 CALL mvopen(9,'millepede.end')
13250 WRITE(9,101) icode, cmessage
13251101 FORMAT(1x,i4,3x,a)
13252 CLOSE(9)
13253 RETURN
13254
13255END SUBROUTINE peend
13256
13263SUBROUTINE binopn(kfile, ithr, ierr)
13264 USE mpmod
13265
13266 IMPLICIT NONE
13267 INTEGER(mpi), INTENT(IN) :: kfile
13268 INTEGER(mpi), INTENT(IN) :: ithr
13269 INTEGER(mpi), INTENT(OUT) :: ierr
13270
13271 INTEGER(mpi), DIMENSION(13) :: ibuff
13272 INTEGER(mpi) :: ioff
13273 INTEGER(mpi) :: ios
13274 INTEGER(mpi) :: k
13275 INTEGER(mpi) :: lfn
13276 INTEGER(mpi) :: lun
13277 INTEGER(mpi) :: moddate
13278 CHARACTER (LEN=1024) :: fname
13279 CHARACTER (LEN=7) :: cfile
13280 INTEGER stat
13281
13282#ifdef READ_C_FILES
13283 INTERFACE
13284 SUBROUTINE openc(filename, lfn, lun, ios) BIND(c)
13285 USE iso_c_binding
13286 CHARACTER(kind=c_char), DIMENSION(*), INTENT(IN) :: filename
13287 INTEGER(c_int), INTENT(IN), VALUE :: lfn
13288 INTEGER(c_int), INTENT(IN), VALUE :: lun
13289 INTEGER(c_int), INTENT(INOUT) :: ios
13290 END SUBROUTINE openc
13291 END INTERFACE
13292#endif
13293
13294 ierr=0
13295 lun=ithr
13296 ! modification date (=0: open for first time, >0: reopen, <0: unknown )
13297 moddate=yfd(kfile)
13298 ! file name
13299 ioff=sfd(1,kfile)
13300 lfn=sfd(2,kfile)
13301 DO k=1,lfn
13302 fname(k:k)=tfd(ioff+k)
13303 END DO
13304 !print *, " opening binary ", kfile, ithr, moddate, " : ", fname(1:lfn)
13305 ! open
13306 ios=0
13307 IF(kfile <= nfilf) THEN
13308 ! Fortran file
13309 lun=kfile+10
13310 OPEN(lun,file=fname(1:lfn),iostat=ios, form='UNFORMATTED')
13311 print *, ' lun ', lun, ios
13312#ifdef READ_C_FILES
13313 ELSE
13314 ! C file
13315 CALL openc(fname(1:lfn),lfn,lun,ios)
13316#else
13317 WRITE(*,*) 'Opening of C-files not supported.'
13318 ierr=1
13319 RETURN
13320#endif
13321 END IF
13322 IF(ios /= 0) THEN
13323 ierr=1
13324 WRITE(*,*) 'Open error for file ',fname(1:lfn), ios
13325 IF (moddate /= 0) THEN
13326 WRITE(cfile,'(I7)') kfile
13327 CALL peend(15,'Aborted, open error(s) for binary file ' // cfile)
13328 stop 'PEREAD: open error'
13329 ENDIF
13330 RETURN
13331 END IF
13332 ! get status
13333 ios=stat(fname(1:lfn),ibuff)
13334 !print *, ' STAT ', ios, ibuff(10), moddate
13335 IF(ios /= 0) THEN
13336 ierr=1
13337 WRITE(*,*) 'STAT error for file ',fname(1:lfn), ios
13338 ibuff(10)=-1
13339 END IF
13340 ! check/store modification date
13341 IF (moddate /= 0) THEN
13342 IF (ibuff(10) /= moddate) THEN
13343 WRITE(cfile,'(I7)') kfile
13344 CALL peend(19,'Aborted, binary file modified (date) ' // cfile)
13345 stop 'PEREAD: file modified'
13346 END IF
13347 ELSE
13348 yfd(kfile)=ibuff(10)
13349 END IF
13350 RETURN
13351
13352END SUBROUTINE binopn
13353
13359SUBROUTINE bincls(kfile, ithr)
13360 USE mpmod
13361
13362 IMPLICIT NONE
13363 INTEGER(mpi), INTENT(IN) :: kfile
13364 INTEGER(mpi), INTENT(IN) :: ithr
13365
13366 INTEGER(mpi) :: lun
13367
13368#ifdef READ_C_FILES
13369 INTERFACE
13370 SUBROUTINE closec(lun) BIND(c)
13371 USE iso_c_binding
13372 INTEGER(c_int), INTENT(IN), VALUE :: lun
13373 END SUBROUTINE closec
13374 END INTERFACE
13375#endif
13376
13377 lun=ithr
13378 !print *, " closing binary ", kfile, ithr
13379 IF(kfile <= nfilf) THEN ! Fortran file
13380 lun=kfile+10
13381 CLOSE(lun)
13382#ifdef READ_C_FILES
13383 ELSE ! C file
13384 CALL closec(lun)
13385#endif
13386 END IF
13387
13388END SUBROUTINE bincls
13389
13394SUBROUTINE binrwd(kfile)
13395 USE mpmod
13396
13397 IMPLICIT NONE
13398 INTEGER(mpi), INTENT(IN) :: kfile
13399
13400 INTEGER(mpi) :: lun
13401
13402#ifdef READ_C_FILES
13403 INTERFACE
13404 SUBROUTINE resetc(lun) BIND(c)
13405 USE iso_c_binding
13406 INTEGER(c_int), INTENT(IN), VALUE :: lun
13407 END SUBROUTINE resetc
13408 END INTERFACE
13409#endif
13410
13411 !print *, " rewinding binary ", kfile
13412 IF (kfile <= nfilf) THEN
13413 lun=kfile+10
13414 rewind lun
13415#ifdef READ_C_FILES
13416 ELSE
13417 lun=kfile-nfilf
13418 CALL resetc(lun)
13419#endif
13420 END IF
13421
13422END SUBROUTINE binrwd
13423
13425SUBROUTINE ckpgrp
13426 USE mpmod
13427 USE mpdalc
13428
13429 IMPLICIT NONE
13430 INTEGER(mpi) :: i
13431 INTEGER(mpi) :: ipgrp
13432 INTEGER(mpi) :: irank
13433 INTEGER(mpi) :: isize
13434 INTEGER(mpi) :: ivoff
13435 INTEGER(mpi) :: itgbi
13436 INTEGER(mpi) :: j
13437 INTEGER(mpi) :: msize
13438 INTEGER(mpi), PARAMETER :: mxsize = 1000
13439 INTEGER(mpl):: ij
13440 INTEGER(mpl):: length
13441
13442 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
13443 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
13444 REAL(mpd), DIMENSION(:), ALLOCATABLE :: resParGroup
13445 REAL(mpd), DIMENSION(:), ALLOCATABLE :: blockParGroup
13446 REAL(mpd) :: matij
13447 SAVE
13448
13449 ! maximal group size
13450 msize=0
13451 DO ipgrp=1,nvpgrp
13452 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13453 IF (isize <= mxsize) THEN
13454 msize=max(msize,isize)
13455 ELSE
13456 print *, ' CKPGRP: par. group', ipgrp, ' not checked -- too large: ', isize
13457 END IF
13458 END DO
13459 IF (msize == 0) RETURN
13460
13461 ! (matrix) block for parameter groups
13462 length=int(msize,mpl)*(int(msize,mpl)+1)/2
13463 CALL mpalloc(blockpargroup,length,'(matrix) block for parameter groups (D)')
13464 length=msize
13465 CALL mpalloc(respargroup,length,'residuals for parameter groups (D)') ! double aux 1
13466 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
13467 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
13468
13469 respargroup=0
13470 print *
13471 print *,' CKPGRP par. group first label size rank'
13472 DO ipgrp=1,nvpgrp
13473 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13474 IF (isize > mxsize) cycle
13475 ! copy matrix block
13476 ivoff=globalallindexgroups(ipgrp)-1
13477 ij=0
13478 DO i=1,isize
13479 DO j=1,i
13480 ij=ij+1
13481 blockpargroup(ij)=matij(ivoff+i,ivoff+j)
13482 END DO
13483 END DO
13484 ! inversion of matrix block
13485 CALL sqminv(blockpargroup,respargroup,isize,irank, auxvectord, auxvectori)
13486 !
13488 IF (isize == irank) THEN
13489 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank
13490 ELSE
13491 ndefpg=ndefpg+1
13492 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank, ' rank deficit !!!'
13493 END IF
13494 END DO
13495
13496 ! clean up
13497 CALL mpdealloc(auxvectord)
13498 CALL mpdealloc(auxvectori)
13499 CALL mpdealloc(respargroup)
13500 CALL mpdealloc(blockpargroup)
13501
13502END SUBROUTINE ckpgrp
13503
13505SUBROUTINE chkmat
13506 USE mpmod
13507
13508 IMPLICIT NONE
13509 INTEGER(mpl) :: i
13510 INTEGER(mpl) :: nan
13511 INTEGER(mpl) :: neg
13512
13513 print *, ' Checking global matrix(D) for NANs ', size(globalmatd,kind=mpl)
13514 nan=0
13515 DO i=1,size(globalmatd,kind=mpl)
13516 IF(.NOT.(globalmatd(i) <= 0.0_mpd).AND..NOT.(globalmatd(i) > 0.0_mpd)) THEN
13517 nan=nan+1
13518 print *, ' i, nan ', i, nan
13519 END IF
13520 END DO
13521
13522 IF (matsto > 1) RETURN
13523 print *
13524 print *, ' Checking diagonal elements ', nagb
13525 neg=0
13526 DO i=1,nagb
13527 IF(.NOT.(globalmatd(globalrowoffsets(i)+i) > 0.0_mpd)) THEN
13528 neg=neg+1
13529 print *, ' i, neg ', i, neg
13530 END IF
13531 END DO
13532 print *
13533 print *, ' CHKMAT summary ', nan, neg
13534 print *
13535
13536END SUBROUTINE chkmat
13537
13538
13539! ----- accurate summation ----(from mpnum) ---------------------------------
13540
13550
13551SUBROUTINE addsums(ithrd, chi2, ndf, dw)
13552 USE mpmod
13553
13554 IMPLICIT NONE
13555 REAL(mpd), INTENT(IN) :: chi2
13556 INTEGER(mpi), INTENT(IN) :: ithrd
13557 INTEGER(mpi), INTENT(IN) :: ndf
13558 REAL(mpd), INTENT(IN) :: dw
13559
13560 INTEGER(mpl) ::nadd
13561 REAL(mpd) ::add
13562 ! ...
13563 add=chi2*dw ! apply (file) weight
13564 nadd=int(add,mpl) ! convert to integer
13565 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+nadd ! sum integer
13566 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)+(add-real(nadd,mpd)) ! sum remainder
13567 IF(globalchi2sumd(ithrd) > 16.0_mpd) THEN ! + - 16
13568 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)-16.0_mpd
13569 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+16_mpl
13570 END IF
13571 globalndfsum(ithrd)=globalndfsum(ithrd)+int(ndf,mpl)
13572 globalndfsumw(ithrd)=globalndfsumw(ithrd)+real(ndf,mpd)*dw
13573 RETURN
13574END SUBROUTINE addsums
13575
13583
13584SUBROUTINE getsums(chi2, ndf, wndf)
13585 USE mpmod
13586
13587 IMPLICIT NONE
13588 REAL(mpd), INTENT(OUT) ::chi2
13589 INTEGER(mpl), INTENT(OUT) ::ndf
13590 REAL(mpd), INTENT(OUT) ::wndf
13591 ! ...
13592 chi2=sum(globalchi2sumd)+real(sum(globalchi2sumi),mpd)
13593 ndf=sum(globalndfsum)
13594 wndf=sum(globalndfsumw)
13595 globalchi2sumd=0.0_mpd
13596 globalchi2sumi=0_mpl
13597 globalndfsum=0_mpl
13598 globalndfsumw=0.0_mpd
13599 RETURN
13600END SUBROUTINE getsums
allocate array
Definition: mpdalc.f90:36
deallocate array
Definition: mpdalc.f90:42
subroutine ptlopt(nf, m, slopes, steps)
Get details.
Definition: linesrch.f90:259
subroutine ptline(n, x, f, g, s, step, info)
Perform linesearch.
Definition: linesrch.f90:90
subroutine ptldef(gtole, stmax, minfe, maxfe)
Initialize line search.
Definition: linesrch.f90:233
subroutine ptlprt(lunp)
Print line search data.
Definition: linesrch.f90:295
subroutine pcbits(npgrp, nsparr, nsparc)
Analyze bit fields.
Definition: mpbits.f90:1034
subroutine ndbits(npgrp, ndims, nsparr, ihst)
Analyze bit fields.
Definition: mpbits.f90:306
subroutine clbits(in, jreqpe, jhispe, jsngpe, jextnd, idimb, ispc)
Calculate bit (field) array size, encoding.
Definition: mpbits.f90:183
subroutine plbits(in, inar, inac, idimb)
Calculate bit field array size (PARDISO).
Definition: mpbits.f90:256
subroutine spbits(npgrp, nsparr, nsparc)
Create sparsity information.
Definition: mpbits.f90:1221
subroutine irbits(i, j)
Fill bit fields (counters, rectangular part).
Definition: mpbits.f90:150
subroutine clbmap(in)
Clear (additional) bit map.
Definition: mpbits.f90:1358
subroutine inbmap(im, jm)
Fill bit map.
Definition: mpbits.f90:1390
subroutine ckbits(npgrp, ndims)
Check sparsity of matrix.
Definition: mpbits.f90:1128
subroutine ggbmap(ipgrp, npair, npgrp)
Get paired (parameter) groups from map.
Definition: mpbits.f90:1470
subroutine prbits(npgrp, nsparr)
Analyze bit fields.
Definition: mpbits.f90:935
subroutine gpbmap(ngroup, npgrp, npair)
Get pairs (statistic) from map.
Definition: mpbits.f90:1424
subroutine pblbits(npgrp, ibsize, nsparr, nsparc)
Analyze bit fields.
Definition: mpbits.f90:762
subroutine pbsbits(npgrp, ibsize, nnzero, nblock, nbkrow)
Analyze bit fields.
Definition: mpbits.f90:579
subroutine inbits(im, jm, inc)
Fill bit fields (counters, triangular part).
Definition: mpbits.f90:74
subroutine hmplun(lunw)
unit for output
Definition: mphistab.f90:329
subroutine gmpdef(ig, ityp, text)
book, reset XY storage
Definition: mphistab.f90:702
subroutine gmpxy(ig, x, y)
add (X,Y) pair
Definition: mphistab.f90:767
subroutine hmpdef(ih, xa, xb, text)
book, reset histogram
Definition: mphistab.f90:122
subroutine gmplun(lunw)
unit for output
Definition: mphistab.f90:975
subroutine gmpxyd(ig, x, y, dx, dy)
add (X,Y,DX,DY)
Definition: mphistab.f90:782
subroutine hmpwrt(ih)
write histogram text file
Definition: mphistab.f90:341
subroutine gmpwrt(ig)
write XY text file
Definition: mphistab.f90:987
subroutine hmpldf(ih, text)
book, reset log histogram
Definition: mphistab.f90:158
subroutine gmprnt(ig)
print XY data
Definition: mphistab.f90:869
subroutine hmpent(ih, x)
entry flt.pt.
Definition: mphistab.f90:183
subroutine hmplnt(ih, ix)
entry integer
Definition: mphistab.f90:223
subroutine gmpms(ig, x, y)
mean sigma(X) from Y
Definition: mphistab.f90:805
subroutine hmprnt(ih)
print, content vert
Definition: mphistab.f90:254
subroutine monend()
End monitoring.
Definition: mpmon.f90:83
subroutine monini(l, n1, n2)
Initialize monitoring.
Definition: mpmon.f90:43
subroutine dbavat(v, a, w, n, m, iopt)
A V AT product (similarity).
Definition: mpnum.f90:1390
subroutine sqminl(v, b, n, nrank, diag, next, vk, mon)
Matrix inversion for LARGE matrices.
Definition: mpnum.f90:231
subroutine devsol(n, diag, u, b, x, work)
Solution by diagonalization.
Definition: mpnum.f90:650
subroutine dbsvxl(v, a, b, n)
Product LARGE symmetric matrix, vector.
Definition: mpnum.f90:1309
subroutine devrot(n, diag, u, v, work, iwork)
Diagonalization.
Definition: mpnum.f90:370
subroutine sort22l(a, b, n)
Quick sort 2 with index.
Definition: mpnum.f90:1982
subroutine dbavats(v, a, is, w, n, m, iopt, sc)
A V AT product (similarity, sparse).
Definition: mpnum.f90:1471
subroutine sqmibb(v, b, n, nbdr, nbnd, inv, nrank, vbnd, vbdr, aux, vbk, vzru, scdiag, scflag, evdmin, evdmax)
Bordered band matrix.
Definition: mpnum.f90:3119
subroutine chslv2(g, x, n)
Solve A*x=b using Cholesky decomposition.
Definition: mpnum.f90:954
subroutine sort1k(a, n)
Quick sort 1.
Definition: mpnum.f90:1715
subroutine sqminv(v, b, n, nrank, diag, next)
Matrix inversion and solution.
Definition: mpnum.f90:98
subroutine presols(p, n, b, nm, cu, a, l, s, x, y)
Constrained (sparse) preconditioner, solution.
Definition: mpnum.f90:2981
subroutine devinv(n, diag, u, v)
Inversion by diagonalization.
Definition: mpnum.f90:697
subroutine sqmibb2(v, b, n, nbdr, nbnd, inv, nrank, vbnd, vbdr, aux, vbk, vzru, scdiag, scflag, evdmin, evdmax)
Band bordered matrix.
Definition: mpnum.f90:3391
subroutine equdecs(n, m, b, nm, ls, c, india, l, nrkd, nrkd2)
Decomposition of (sparse) equilibrium systems.
Definition: mpnum.f90:2487
subroutine chdec2(g, n, nrank, evmax, evmin, mon)
Cholesky decomposition (LARGE pos.
Definition: mpnum.f90:892
subroutine sort2k(a, n)
Quick sort 2.
Definition: mpnum.f90:1800
subroutine devsig(n, diag, u, b, coef)
Calculate significances.
Definition: mpnum.f90:612
subroutine dbsvx(v, a, b, n)
Product symmetric matrix, vector.
Definition: mpnum.f90:1265
subroutine equslvs(n, m, b, nm, c, india, l, x)
Solution of (sparse) equilibrium systems (after decomposition).
Definition: mpnum.f90:2614
subroutine precons(p, n, b, nm, c, cu, a, l, s, nrkd)
Constrained (sparse) preconditioner, decomposition.
Definition: mpnum.f90:2882
subroutine sort2i(a, n)
Quick sort 2 with index.
Definition: mpnum.f90:1893
subroutine qlpssq(aprod, B, m, t)
Partial similarity transformation by Q(t).
Definition: mpqldec.f90:712
subroutine qldecb(a, bpar, bcon, rcon)
QL decomposition (for disjoint block matrix).
Definition: mpqldec.f90:220
subroutine qlmlq(x, m, t)
Multiply left by Q(t) (per block).
Definition: mpqldec.f90:405
subroutine qlsetb(ib)
Set block.
Definition: mpqldec.f90:1019
subroutine qlbsub(d, y)
Backward substitution (per block).
Definition: mpqldec.f90:992
subroutine qlini(n, m, l, s, k)
Initialize QL decomposition.
Definition: mpqldec.f90:62
subroutine qlgete(emin, emax)
Get eigenvalues.
Definition: mpqldec.f90:956
subroutine qlssq(aprod, A, s, roff, t)
Similarity transformation by Q(t).
Definition: mpqldec.f90:574
subroutine mptest
Generate test files.
Definition: mptest1.f90:79
subroutine mptst2(imodel)
Generate test files.
Definition: mptest2.f90:112
integer(mpi) function matint(pat, text, npat, ntext)
Approximate string matching.
Definition: mptext.f90:309
subroutine ratext(text, nums, dnum, mnum)
Translate text.
Definition: mptext.f90:51
subroutine rltext(text, ia, ib, nab)
Analyse text range.
Definition: mptext.f90:256
MINRES solves symmetric systems Ax = b or min ||Ax - b||_2, where the matrix A may be indefinite and/...
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.
MINRESQLP solves symmetric systems Ax = b or min ||Ax - b||_2, where the matrix A may be indefinite a...
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.
(De)Allocate vectors and arrays.
Definition: mpdalc.f90:24
integer(mpl) maxwordsalloc
peak dynamic memory allocation (words)
Definition: mpdalc.f90:30
integer(mpi) printflagalloc
print flag for dynamic allocations
Definition: mpdalc.f90:33
Definition of constants.
Definition: mpdef.f90:24
integer, parameter mpl
long integer
Definition: mpdef.f90:36
integer, parameter mps
single precision
Definition: mpdef.f90:37
integer, parameter mpi
integer
Definition: mpdef.f90:35
Parameters, variables, dynamic arrays.
Definition: mpmod.f90:28
integer(mpl), dimension(:), allocatable csr3columnlist
list of columns for sparse matrix
Definition: mpmod.f90:284
integer(mpl) mszpcc
(integrated block) matrix size for constraint matrix for preconditioner
Definition: mpmod.f90:145
real(mpd), dimension(:), allocatable workspaceeigenvectors
workspace eigen vectors
Definition: mpmod.f90:232
real(mpd), dimension(:), allocatable globalparameter
global parameters (start values + sum(x_i))
Definition: mpmod.f90:198
integer(mpl) nrecal
number of records
Definition: mpmod.f90:168
integer(mpi), dimension(:), allocatable localglobalmap
matrix correlating local and global par, map (counts)
Definition: mpmod.f90:315
type(listitem), dimension(:), allocatable listparameters
list of parameters from steering file
Definition: mpmod.f90:332
integer(mpi), dimension(:), allocatable vecparblockconoffsets
global par block (constraint) offsets
Definition: mpmod.f90:299
real(mpd), dimension(:), allocatable lapacktau
LAPACK TAU (QL decomp.)
Definition: mpmod.f90:238
integer(mpl) mszprd
(integrated block) matrix size for (constraint) product matrix
Definition: mpmod.f90:143
integer(mpi) lunmon
unit for monitoring output file
Definition: mpmod.f90:127
real(mpd), dimension(:), allocatable vecconsresiduals
residuals of constraints
Definition: mpmod.f90:244
integer(mpl) nrec1
record number with largest residual
Definition: mpmod.f90:53
integer(mpi) iskpec
flag for skipping empty constraints (no variable parameters)
Definition: mpmod.f90:106
integer(mpi) mnrsel
number of MINRES error labels in LBMNRS (calc err, corr with SOLGLO)
Definition: mpmod.f90:89
real(mps) actfun
actual function change
Definition: mpmod.f90:67
integer(mpi), dimension(:), allocatable globalindexusage
indices of global par in record
Definition: mpmod.f90:292
real(mps) regpre
default presigma
Definition: mpmod.f90:72
integer(mpi) mnrsit
total number of MINRES internal iterations
Definition: mpmod.f90:93
integer(mpi), dimension(10) ipdbsz
PARDISO, list of block sizes to be tried (by PBSBITS)
Definition: mpmod.f90:185
integer(mpi) metsol
solution method (1: inversion, 2: diagonalization, 3: decomposition, 4: MINRES, 5: MINRES-QLP,...
Definition: mpmod.f90:34
integer(mpi) nagbn
max number of global paramters per record
Definition: mpmod.f90:146
character(len=74) textl
name of current MP 'module' (step)
Definition: mpmod.f90:159
integer(mpi) nloopn
number of data reading, fitting loops
Definition: mpmod.f90:43
integer(mpl) sumrecords
sum of records
Definition: mpmod.f90:190
integer(mpi) mreqpe
min number of pair entries
Definition: mpmod.f90:80
integer(mpi) memdbg
debug flag for memory management
Definition: mpmod.f90:96
integer(mpi), dimension(100) lbmnrs
MINRES error labels.
Definition: mpmod.f90:179
integer(mpi) ncgrp
number of (disjoint) constraint groups
Definition: mpmod.f90:140
real(mpd) mrtcnd
transition (QR -> QLP) (matrix) condition for MINRES-QLP
Definition: mpmod.f90:62
real(mpd), dimension(:), allocatable vbk
local fit 'matrix for border solution'
Definition: mpmod.f90:308
real(mps) prange
range (-PRANGE..PRANGE) for histograms of pulls, norm.
Definition: mpmod.f90:97
integer(mpi) matsto
(global) matrix storage mode (0: unpacked, 1: full = packed, 2: sparse(custom), 3: sparse(CSR3,...
Definition: mpmod.f90:35
integer(mpi), dimension(:,:), allocatable matconssort
keys and index for sorting
Definition: mpmod.f90:249
character(len=1024) cpostproc
post processing string
Definition: mpmod.f90:350
real(mpd), dimension(:), allocatable lapackwork
LAPACK work array.
Definition: mpmod.f90:239
integer(mpi) monpg1
progress monitoring, repetition rate start value
Definition: mpmod.f90:116
integer(mpi), dimension(:,:), allocatable readbufferinfo
buffer management (per thread)
Definition: mpmod.f90:286
integer(mpi) nhistp
flag for histogram printout
Definition: mpmod.f90:65
integer(mpl), dimension(:), allocatable csr3rowoffsets
row offsets for column list
Definition: mpmod.f90:283
real(mpd), dimension(:), allocatable globalparcopy
copy of global parameters
Definition: mpmod.f90:199
real(mpd), dimension(:), allocatable lapackql
LAPACK QL (QL decomp.)
Definition: mpmod.f90:237
real(mpd), dimension(2) dscerr
scaling factors for errors of 'global' and 'local' measurement
Definition: mpmod.f90:112
real(mps) chhuge
cut in terms of 3-sigma for unreasonable data, all iterations
Definition: mpmod.f90:50
integer(mpi), dimension(:), allocatable sparsematrixcolumns
(compressed) list of columns for sparse matrix
Definition: mpmod.f90:280
integer(mpl), dimension(:,:), allocatable sparsematrixoffsets
row offsets for column list, sparse matrix elements
Definition: mpmod.f90:281
integer(mpi) iteren
entries cut is iterated for parameters with less entries (if > mreqenf)
Definition: mpmod.f90:105
integer(mpi), dimension(:,:), allocatable matconsranges
parameter ranges for constraints
Definition: mpmod.f90:248
integer(mpi) lunkno
flag for unkown keywords
Definition: mpmod.f90:46
integer(mpi), dimension(:), allocatable scflag
local fit workspace (I)
Definition: mpmod.f90:311
real(mpd), parameter measbinsize
bins size for monitoring
Definition: mpmod.f90:178
integer(mpi) mdebug
debug flag (number of records to print)
Definition: mpmod.f90:38
integer(mpi) npblck
number of (disjoint) parameter blocks (>1: block diagonal storage)
Definition: mpmod.f90:139
real(mpd), dimension(:), allocatable matconsproduct
product matrix of constraints
Definition: mpmod.f90:243
integer(mpi), dimension(:), allocatable yfd
binary file: modification date
Definition: mpmod.f90:365
integer(mpi) nxlow
(max of) global parameters with too few accepted entries for icalcm=1
Definition: mpmod.f90:173
integer(mpl) ndgb
number of global derivatives read
Definition: mpmod.f90:153
real(mps) value1
largest residual
Definition: mpmod.f90:55
integer(mpi) ipddbg
flag for debugging Intel oneMKL PARDISO
Definition: mpmod.f90:121
real(mpd), dimension(:), allocatable localcorrections
local fit corrections (to residuals)
Definition: mpmod.f90:313
integer(mpl) nrec3
(1.) record number with error
Definition: mpmod.f90:79
real(mps) chirem
cut in terms of 3-sigma cut, other iterations, approaching 1.
Definition: mpmod.f90:49
real(mpd), dimension(:), allocatable localglobalmatrix
matrix correlating local and global par, content
Definition: mpmod.f90:314
integer(mpi) mhispe
upper bound for pair entry histogrammimg
Definition: mpmod.f90:81
integer(mpi) nfgb
number of fit parameters
Definition: mpmod.f90:133
integer(mpi), dimension(:,:), allocatable kfd
(1,.)= number of records in file, (2,..)= file order
Definition: mpmod.f90:356
real(mpd), dimension(:), allocatable globalchi2sumd
fractional part of Chi2 sum
Definition: mpmod.f90:221
integer(mpi) icheck
flag for checking input only (no solution determined)
Definition: mpmod.f90:103
integer(mpi), dimension(:), allocatable jfd
file: number of accepted records
Definition: mpmod.f90:358
integer(mpl) nzgb
number of zero global derivatives read
Definition: mpmod.f90:154
integer(mpl) nrecer
record with error (rank deficit or Not-a-Number) for printout
Definition: mpmod.f90:78
integer(mpi) matmon
record interval for monitoring of (sparse) matrix construction
Definition: mpmod.f90:86
integer(mpi) nbndx
max band width for local fit
Definition: mpmod.f90:77
type(listitem), dimension(:), allocatable listconstraints
list of constraints from steering file
Definition: mpmod.f90:336
real(mpd), dimension(:), allocatable globalmatd
global matrix 'A' (double, full or sparse)
Definition: mpmod.f90:207
real(mpr8), dimension(:), allocatable readbufferdatad
double data
Definition: mpmod.f90:290
type(listitem), dimension(:), allocatable listmeasurements
list of (external) measurements from steering file
Definition: mpmod.f90:339
integer(mpi) lsinfo
line search: returned information
Definition: mpmod.f90:164
integer(mpi) nregul
regularization flag
Definition: mpmod.f90:70
integer(mpi) nfilw
number of weighted binary files
Definition: mpmod.f90:374
integer(mpi) ndefpg
number of parameter groups with rank deficit (from inversion)
Definition: mpmod.f90:170
integer(mpi), dimension(:), allocatable paircounter
number of paired parameters (in equations)
Definition: mpmod.f90:295
integer(mpi) nummeasurements
number of (external) measurements from steering file
Definition: mpmod.f90:337
integer(mpl) nrec2
record number with largest chi^2/Ndf
Definition: mpmod.f90:54
integer(mpi) ndimbuf
default read buffer size (I/F words, half record length)
Definition: mpmod.f90:375
real(mpd) fvalue
function value (chi2 sum) solution
Definition: mpmod.f90:180
real(mpd), dimension(:), allocatable globalcorrections
correction x_i (from A*x_i=b_i in iteration i)
Definition: mpmod.f90:200
real(mps), dimension(:), allocatable cfd
file: chi2 sum
Definition: mpmod.f90:361
real(mps) regula
regularization parameter, add regula * norm(global par.) to objective function
Definition: mpmod.f90:71
integer(mpi) nspc
number of precision for sparse global matrix (1=D, 2=D+F)
Definition: mpmod.f90:175
integer(mpi) nfilc
number of C binary files
Definition: mpmod.f90:373
integer(mpi) nagb
number of all parameters (var.
Definition: mpmod.f90:132
integer(mpi) nmiss1
rank deficit for constraints
Definition: mpmod.f90:171
integer(mpi), dimension(:), allocatable globalparhashtable
global parameters hash table
Definition: mpmod.f90:262
integer(mpi) nalow
(sum of) global parameters with too few accepted entries
Definition: mpmod.f90:172
integer(mpi) iscerr
flag for scaling of errors
Definition: mpmod.f90:111
real(mpd) sumndf
weighted sum(ndf)
Definition: mpmod.f90:182
integer(mpi), dimension(2) nbndr
number of records with bordered band matrix for local fit (upper/left, lower/right)
Definition: mpmod.f90:75
integer(mpl), dimension(:), allocatable lapackipiv
LAPACK IPIV (pivot)
Definition: mpmod.f90:240
integer(mpi) iterat
iterations in solution
Definition: mpmod.f90:69
real(mpd) flines
function value line search
Definition: mpmod.f90:181
integer(mpi), dimension(:), allocatable meashists
measurement histograms (100 bins per thread)
Definition: mpmod.f90:256
integer(mpi), dimension(:), allocatable globalindexranges
global par ranges
Definition: mpmod.f90:297
integer(mpi) mthrd
number of (OpenMP) threads
Definition: mpmod.f90:84
integer(mpi) mbandw
band width of preconditioner matrix
Definition: mpmod.f90:44
integer(mpl) lplwrk
length of LAPACK WORK array
Definition: mpmod.f90:236
real(mps) dwcut
down-weight fraction cut
Definition: mpmod.f90:57
integer(mpl), dimension(:), allocatable globalcounter
global counter (entries in 'x')
Definition: mpmod.f90:211
real(mps), dimension(:), allocatable globalmatf
global matrix 'A' (float part for compressed sparse)
Definition: mpmod.f90:208
integer(mpi), dimension(:,:), allocatable matconsgroups
start of constraint groups, parameter range
Definition: mpmod.f90:250
real(mps), dimension(0:8) times
cpu time counters
Definition: mpmod.f90:157
integer(mpi) minrecordsinblock
min.
Definition: mpmod.f90:192
integer(mpi), dimension(:), allocatable localglobalstructure
matrix correlating local and global par, (sparsity) structure
Definition: mpmod.f90:316
real(mpd), dimension(:), allocatable globalndfsumw
weighted NDF sum
Definition: mpmod.f90:224
integer(mpi) naeqn
max number of equations (measurements) per record
Definition: mpmod.f90:148
integer(mpi) nfilb
number of binary files
Definition: mpmod.f90:371
real(mpd), dimension(:), allocatable vzru
local fit 'border solution'
Definition: mpmod.f90:309
real(mpd), dimension(:), allocatable globalparpreweight
weight from pre-sigma
Definition: mpmod.f90:203
integer(mpi) ictest
test mode '-t'
Definition: mpmod.f90:33
real(mpd), dimension(:), allocatable vbdr
local fit border part of 'A'
Definition: mpmod.f90:306
integer(mpi) mdebg2
number of measurements for record debug printout
Definition: mpmod.f90:39
integer(mpi), dimension(:,:), allocatable globaltotindexgroups
Definition: mpmod.f90:276
integer(mpi), dimension(:), allocatable vecconsgroupcounts
counter for constraint groups
Definition: mpmod.f90:251
real(mps) deltim
cpu time difference
Definition: mpmod.f90:166
integer(mpi) igcorr
flag for output of global correlations for inversion, =0: none
Definition: mpmod.f90:95
integer(mpi), dimension(-8:0) globalparheader
global parameters (mapping) header
Definition: mpmod.f90:265
integer(mpi) lencomments
length of list of (global parameter) comments from steering file
Definition: mpmod.f90:340
integer(mpl), dimension(:), allocatable offprecond
preconditioner (block matrix) offsets
Definition: mpmod.f90:219
real(mpd), dimension(:), allocatable vecconssolution
solution for constraint elimination
Definition: mpmod.f90:245
integer(mpi) nfiles
number of files
Definition: mpmod.f90:370
integer(mpi) ipcntr
flag for output of global parameter counts (entries), =0: none, =1: local fits, >1: binary files
Definition: mpmod.f90:100
integer(mpl) negb
number of equations read with global parameters
Definition: mpmod.f90:152
integer(mpi) keepopen
flag for keeping binary files open
Definition: mpmod.f90:113
real(mpd), dimension(:), allocatable workspacediagonalization
workspace diag.
Definition: mpmod.f90:230
real(mps), dimension(:), allocatable wfd
binary file: weight
Definition: mpmod.f90:363
real(mpd), dimension(:), allocatable matprecond
preconditioner matrix (band and other parts)
Definition: mpmod.f90:216
integer(mpi) ntgb
total number of global parameters
Definition: mpmod.f90:130
real(mps) angras
angle between gradient and search direction
Definition: mpmod.f90:68
type(listitemc), dimension(:), allocatable listcomments
list of comments from steering file
Definition: mpmod.f90:341
integer(mpi) mthrdr
number of threads for reading binary files
Definition: mpmod.f90:92
integer(mpi) numreadbuffer
number of buffers (records) in (read) block
Definition: mpmod.f90:188
integer(mpi) imonmd
monitoring mode: 0:residuals (normalized to average error), 1:pulls
Definition: mpmod.f90:110
character(len=1024) filnam
name of steering file
Definition: mpmod.f90:366
integer(mpi) lunlog
unit for logfile
Definition: mpmod.f90:128
integer(mpi) ncblck
number of (non overlapping) constraint blocks
Definition: mpmod.f90:141
real(mps), dimension(3) fcache
read cache, average fill level; write cache; dynamic size
Definition: mpmod.f90:91
real(mps) wolfc2
C_2 of strong Wolfe condition.
Definition: mpmod.f90:60
real(mpd), dimension(:), allocatable workspacerow
(pivot) row of global matrix (for global corr.)
Definition: mpmod.f90:228
integer(mpi) maxrecordsinblock
max.
Definition: mpmod.f90:193
real(mpd) mrestl
tolerance criterion for MINRES-QLP
Definition: mpmod.f90:61
real(mpd), dimension(:), allocatable globalparpresigma
pre-sigma for global parameters
Definition: mpmod.f90:202
integer(mpi) icelim
flag for using elimination (instead of multipliers) for constraints
Definition: mpmod.f90:102
integer(mpi) mitera
number of iterations
Definition: mpmod.f90:42
integer(mpi) lenpardiso
length of list of Intel oneMKL PARDISO parameters (indices 1..64)
Definition: mpmod.f90:344
integer(mpi) nbdrx
max border size for local fit
Definition: mpmod.f90:76
integer(mpi), dimension(:,:), allocatable globalparlabelindex
global parameters label, total -> var.
Definition: mpmod.f90:259
real(mpd), dimension(:), allocatable scdiag
local fit workspace (D)
Definition: mpmod.f90:310
integer(mpi), dimension(:), allocatable readbufferdatai
integer data
Definition: mpmod.f90:288
integer(mpi) mextnd
flag for extended storage (both 'halves' of sym.
Definition: mpmod.f90:83
integer(mpi), dimension(:,:), allocatable sfd
offset (1,..), length (2,..) of binary file name in tfd
Definition: mpmod.f90:364
integer(mpi) lenconstraints
length of list of constraints from steering file
Definition: mpmod.f90:335
integer(mpi), dimension(:), allocatable blockprecond
preconditioner (constraint) blocks
Definition: mpmod.f90:218
integer(mpi) lenparameters
list items from steering file
Definition: mpmod.f90:331
integer(mpi) lprecm
additional flag for preconditioner (band) matrix (>0: preserve rank by skyline matrix)
Definition: mpmod.f90:45
integer(mpi) ndefec
rank deficit for global matrix (from inversion)
Definition: mpmod.f90:169
integer(mpi) lenpostproc
length of post processing string
Definition: mpmod.f90:349
integer(mpl) nrecp2
record number with printout
Definition: mpmod.f90:52
integer(mpl) nrec
number of records read
Definition: mpmod.f90:149
integer(mpi), dimension(:,:), allocatable matparblockoffsets
global par block offsets (parameter, constraint blocks)
Definition: mpmod.f90:298
integer(mpl) nrecpr
record number with printout
Definition: mpmod.f90:51
integer(mpl), dimension(:), allocatable ifd
file: integrated record numbers (=offset)
Definition: mpmod.f90:357
integer(mpi) nofeas
flag for skipping making parameters feasible
Definition: mpmod.f90:64
integer(mpi) matbsz
(global) matrix (fixed) block size, only used for BSR3 storage mode (Intel oneMKL PARDISO)
Definition: mpmod.f90:36
integer(mpi) nfnam
length of sterring file name
Definition: mpmod.f90:367
real rstart
cpu start time for solution iterations
Definition: mpmod.f90:165
integer(mpi), dimension(:), allocatable writebufferindices
write buffer for indices
Definition: mpmod.f90:320
integer(mpi) iforce
switch to SUBITO for (global) rank defects if zero
Definition: mpmod.f90:94
real(mpd), dimension(:), allocatable workspacelinesearch
workspace line search
Definition: mpmod.f90:229
integer(mpi), dimension(:), allocatable globalparvartototal
global parameters variable -> total index
Definition: mpmod.f90:263
real(mpd), dimension(:), allocatable clmat
local fit matrix 'A' (in A*x=b)
Definition: mpmod.f90:302
integer(mpi), dimension(:), allocatable lfd
length of file name
Definition: mpmod.f90:354
integer(mpi) ntpgrp
number of parameter groups
Definition: mpmod.f90:136
character, dimension(:), allocatable tfd
file names (concatenation)
Definition: mpmod.f90:368
integer(mpi) ncgbe
number of empty constraints (no variable parameters)
Definition: mpmod.f90:135
integer(mpi) mprint
print flag (0: minimal, 1: normal, >1: more)
Definition: mpmod.f90:37
integer(mpi), dimension(:), allocatable vecconsstart
start of constraint in listConstraints (unsorted input)
Definition: mpmod.f90:247
integer(mpi) nummeas
number of measurement groups for monitoring
Definition: mpmod.f90:177
integer(mpi) lvllog
log level
Definition: mpmod.f90:129
integer(mpi), dimension(3) nprecond
number of constraints (blocks), matrix size for preconditioner
Definition: mpmod.f90:144
integer(mpi) nalcn
max number of local paramters per record
Definition: mpmod.f90:147
integer(mpi), dimension(:), allocatable globalparcomments
global parameters comments
Definition: mpmod.f90:205
integer(mpi) mreqenf
required number of entries (for variable global parameter from binary Files)
Definition: mpmod.f90:40
real(mps) value2
largest chi^2/Ndf
Definition: mpmod.f90:56
integer(mpi) icalcm
calculation mode (for XLOOPN) , >0: calculate matrix
Definition: mpmod.f90:74
integer(mpi) mcount
flag for grouping and counting global parameters on equlation (0) or record (1) level
Definition: mpmod.f90:115
real(mps), dimension(:), allocatable ofd
file: option
Definition: mpmod.f90:362
integer(mpi) ireeof
flag for treating (binary file) read errors as end-of-file
Definition: mpmod.f90:114
integer(mpi) ifile
current file (index)
Definition: mpmod.f90:369
real(mps) delfun
expected function change
Definition: mpmod.f90:66
integer(mpi) iitera
MINRES iterations.
Definition: mpmod.f90:162
integer(mpl) skippedrecords
number of skipped records (buffer too small)
Definition: mpmod.f90:191
integer(mpi) lenmeasurements
length of list of (external) measurements from steering file
Definition: mpmod.f90:338
real(mps) wolfc1
C_1 of strong Wolfe condition.
Definition: mpmod.f90:59
real(mpd), dimension(:), allocatable aux
local fit 'solutions for border rows'
Definition: mpmod.f90:307
integer(mpi) napgrp
number of all parameter groups (variable + Lagrange mult.)
Definition: mpmod.f90:138
integer(mpl) nrecd
number of records read containing doubles
Definition: mpmod.f90:150
integer(mpi), dimension(:,:), allocatable localequations
indices (ISJAJB) for local equations (measurements)
Definition: mpmod.f90:312
integer(mpi), dimension(:), allocatable globalallpartogroup
all parameters variable -> group index
Definition: mpmod.f90:264
integer(mpi), dimension(:), allocatable backindexusage
list of global par in record
Definition: mpmod.f90:293
integer(mpi), dimension(:), allocatable ibandh
local fit 'band width histogram' (band size autodetection)
Definition: mpmod.f90:303
integer(mpi) isubit
subito flag '-s'
Definition: mpmod.f90:58
integer(mpi), dimension(:), allocatable indprecond
preconditioner pointer array
Definition: mpmod.f90:217
real(mps) dflim
convergence limit
Definition: mpmod.f90:155
integer(mpi) ncache
buffer size for caching (default 100MB per thread)
Definition: mpmod.f90:90
integer(mpi) mxrec
max number of records
Definition: mpmod.f90:85
integer(mpi) mpdbsz
PARDISO, number of block sizes to be tried (by PBSBITS)
Definition: mpmod.f90:184
integer(mpi) lfitnp
local fit: number of iteration to calculate pulls
Definition: mpmod.f90:87
integer(mpl), dimension(6) nrejec
rejected records
Definition: mpmod.f90:156
integer(mpl), dimension(:), allocatable globalparlabelcounter
global parameters label counters
Definition: mpmod.f90:260
integer(mpi) lcalcm
last calclation mode
Definition: mpmod.f90:174
real(mpd), dimension(:), allocatable globalvector
global vector 'x' (in A*x=b)
Definition: mpmod.f90:209
real(mpd), dimension(:), allocatable writebufferupdates
write buffer for update matrices
Definition: mpmod.f90:321
integer(mpi) irslvrc
flag for resolving redundancy constraints (two equivalent parameter groups)
Definition: mpmod.f90:107
real(mpd), dimension(:), allocatable workspaced
(general) workspace (D)
Definition: mpmod.f90:226
integer(mpl) neqn
number of equations (measurements) read
Definition: mpmod.f90:151
integer(mpi) measbins
number of bins per measurement for monitoring
Definition: mpmod.f90:109
integer(mpl) mszcon
(integrated block) matrix size for constraint matrix
Definition: mpmod.f90:142
integer(mpi), dimension(:), allocatable nfd
index (line) in (steering) file
Definition: mpmod.f90:355
integer(mpi) ilperr
flag to calculate parameter errors with LAPACK
Definition: mpmod.f90:119
integer(mpl), dimension(:), allocatable globalparlabelzeros
global parameters label with zero derivative counters
Definition: mpmod.f90:261
integer(mpi) numblocks
number of (read) blocks
Definition: mpmod.f90:189
integer(mpi) ncgb
number of constraints
Definition: mpmod.f90:134
integer(mpi), dimension(:,:), allocatable matconsblocks
start of constraint blocks, parameter range
Definition: mpmod.f90:253
real(mpd), dimension(:), allocatable workspaceeigenvalues
workspace eigen values
Definition: mpmod.f90:231
integer(mpi) lhuber
Huber down-weighting flag.
Definition: mpmod.f90:47
integer(mpi) nvgb
number of variable global parameters
Definition: mpmod.f90:131
integer(mpi) nfilf
number of Fortran binary files
Definition: mpmod.f90:372
integer(mpi), dimension(:), allocatable measindex
mapping of 1.
Definition: mpmod.f90:255
integer(mpi) istopa
MINRES istop (convergence)
Definition: mpmod.f90:163
integer(mpi), dimension(:), allocatable mfd
file mode: cbinary =1, text =2, fbinary=3
Definition: mpmod.f90:353
real(mpd), dimension(:), allocatable blvec
local fit vector 'b' (in A*x=b), replaced by 'x'
Definition: mpmod.f90:301
logical newite
flag for new iteration
Definition: mpmod.f90:160
integer(mpi) nrderr
number of binary files with read errors
Definition: mpmod.f90:183
real(mpd), dimension(:), allocatable measres
average measurement error
Definition: mpmod.f90:257
real(mpd), dimension(:), allocatable vecxav
vector x for AVPROD (A*x=b)
Definition: mpmod.f90:213
real(mpd), dimension(:), allocatable globalparstart
start value for global parameters
Definition: mpmod.f90:201
integer(mpi), dimension(-6:6) writebufferheader
write buffer header (-6..-1: updates, 1..6: indices)
Definition: mpmod.f90:322
integer(mpi) monpg2
progress monitoring, repetition rate max increase
Definition: mpmod.f90:117
integer(mpl), dimension(:), allocatable globalrowoffsets
row offsets for full or unpacked matrix
Definition: mpmod.f90:210
integer(mpi) lenpresigmas
length of list of pre-sigmas from steering file
Definition: mpmod.f90:333
integer(mpi) npresg
number of pre-sigmas
Definition: mpmod.f90:167
integer(mpi), dimension(:), allocatable appearancecounter
appearance statistics for global par (first/last file,record)
Definition: mpmod.f90:294
integer(mpi) nvpgrp
number of variable parameter groups
Definition: mpmod.f90:137
integer(mpi), dimension(:), allocatable xfd
file: max.
Definition: mpmod.f90:360
integer(mpi) mreqena
required number of entries (for variable global parameter from Accepted local fits)
Definition: mpmod.f90:41
real(mps), dimension(:,:), allocatable writebufferdata
write buffer data (largest residual, Chi2/ndf, per thread)
Definition: mpmod.f90:319
real(mpd), dimension(:), allocatable workspacediag
diagonal of global matrix (for global corr.)
Definition: mpmod.f90:227
integer(mpl) ndfsum
sum(ndf)
Definition: mpmod.f90:161
integer(mpi) lenglobalvec
length of global vector 'b' (A*x=b)
Definition: mpmod.f90:194
real(mps) stepl
step length (line search)
Definition: mpmod.f90:158
integer(mpi) msngpe
upper bound for pair entry single precision storage
Definition: mpmod.f90:82
real(mps) cndlmx
cut on log10(condition of band part) of local (bordered-band matrix) fit
Definition: mpmod.f90:124
real(mpd), dimension(:), allocatable vecbav
vector b for AVPROD (A*x=b)
Definition: mpmod.f90:214
integer(mpl), dimension(:), allocatable globalchi2sumi
integer part of Chi2 sum
Definition: mpmod.f90:222
integer(mpl) ipdmem
memory (kB) used by Intel oneMKL PARDISO
Definition: mpmod.f90:346
integer(mpi), dimension(:), allocatable readbufferpointer
pointer to used buffers
Definition: mpmod.f90:287
integer(mpi), dimension(:), allocatable workspacei
(general) workspace (I)
Definition: mpmod.f90:233
integer(mpi), dimension(:), allocatable globalparcons
global parameters (number of) constraints
Definition: mpmod.f90:204
integer(mpi), dimension(:,:), allocatable writebufferinfo
write buffer management (per thread)
Definition: mpmod.f90:318
integer(mpl), dimension(:), allocatable globalndfsum
NDF sum.
Definition: mpmod.f90:223
integer(mpi) matrit
matrix calculation up to iteration MATRIT
Definition: mpmod.f90:73
real(mpd), dimension(:), allocatable vbnd
local fit band part of 'A'
Definition: mpmod.f90:305
real(mpr4), dimension(:), allocatable readbufferdataf
float data
Definition: mpmod.f90:289
type(listitemi), dimension(:), allocatable listpardiso
list of Intel oneMKL PARDISO parameters
Definition: mpmod.f90:345
integer(mpi) lfitbb
local fit: check for bordered band matrix (if >0)
Definition: mpmod.f90:88
integer(mpi) lsearch
iterations (solutions) with line search: >2: all, =2: all with (next) Chi2 cut scaling factor =1....
Definition: mpmod.f90:98
integer(mpi), dimension(:), allocatable dfd
file: ndf sum
Definition: mpmod.f90:359
integer(mpi) ichkpg
flag for checking (rank of) parameter groups
Definition: mpmod.f90:104
type(listitem), dimension(:), allocatable listpresigmas
list of pre-sgmas from steering file
Definition: mpmod.f90:334
integer(mpi), dimension(:), allocatable globalallindexgroups
Definition: mpmod.f90:277
integer(mpi) mrmode
MINRES-QLP mode (0: QR+QLP, 1: only QR, 2: only QLP factorization)
Definition: mpmod.f90:63
real(mps) chicut
cut in terms of 3-sigma cut, first iteration
Definition: mpmod.f90:48
integer(mpi) imonit
flag for monitoring residuals per local fit cycle (=0: none, <0: all, bit 0: first,...
Definition: mpmod.f90:108
Parameters and data.
Definition: mptest1.f90:35
real(mps), dimension(nplan) dvd
rel.
Definition: mptest1.f90:53
real(mps), dimension(nplan) del
shift (position deviation) (alignment parameter)
Definition: mptest1.f90:52
integer(mpi), parameter nplan
Definition: mptest1.f90:41
Parameters and data.
Definition: mptest2.f90:57
integer(mpi), parameter nmx
number of modules in x direction
Definition: mptest2.f90:65
real(mps), dimension(ntot) sdevx
shift in x (alignment parameter)
Definition: mptest2.f90:82
real(mps), dimension(ntot) sdevy
shift in y (alignment parameter)
Definition: mptest2.f90:83
integer(mpi), parameter nmy
number of modules in y direction
Definition: mptest2.f90:67
integer(mpi), parameter nlyr
number of detector layers
Definition: mptest2.f90:63
integer(mpi), parameter ntot
total number of modules
Definition: mptest2.f90:68
Keyword position.
Definition: mptext.f90:29
integer(mpi) keyb
end (position) of first keyword
Definition: mptext.f90:35
integer(mpi) keya
start (position) of first keyword
Definition: mptext.f90:34
integer(mpi) keyc
end (position) of last keyword
Definition: mptext.f90:36
subroutine ploopb(lunp)
Print iteration line.
Definition: pede.f90:3879
subroutine mchdec
Solution by Cholesky decomposition.
Definition: pede.f90:9070
subroutine bincls(kfile, ithr)
Close binary file.
Definition: pede.f90:13360
subroutine prpcon
Prepare constraints.
Definition: pede.f90:1961
subroutine mminrs
Solution with MINRES.
Definition: pede.f90:10144
subroutine prtrej(lun)
Print rejection statistics.
Definition: pede.f90:5397
subroutine mcsolv(n, x, y)
Solution for zero band width preconditioner.
Definition: pede.f90:10348
subroutine mupdat(i, j, add)
Update element of global matrix.
Definition: pede.f90:4101
subroutine peend(icode, cmessage)
Print exit code.
Definition: pede.f90:13243
subroutine loopn
Loop with fits and sums.
Definition: pede.f90:3444
subroutine loop1
First data loop (get global labels).
Definition: pede.f90:6948
subroutine feasma
Matrix for feasible solution.
Definition: pede.f90:2261
subroutine xloopn
Standard solution algorithm.
Definition: pede.f90:10402
subroutine ploopa(lunp)
Print title for iteration.
Definition: pede.f90:3858
subroutine isjajb(nst, is, ja, jb, jsp)
Decode Millepede record.
Definition: pede.f90:3393
subroutine additem(length, list, label, value)
add item to list
Definition: pede.f90:12983
subroutine mgupdt(i, j1, j2, il, jl, n, sub)
Update global matrix for parameter group.
Definition: pede.f90:4186
subroutine lpavat(t)
Similarity transformation by Q(t).
Definition: pede.f90:9632
subroutine binrwd(kfile)
Rewind binary file.
Definition: pede.f90:13395
subroutine zdiags
Covariance matrix for diagonalization (,correction of eigenvectors).
Definition: pede.f90:10107
subroutine solglo(ivgbi)
Error for single global parameter from MINRES.
Definition: pede.f90:1422
subroutine upone
Update, redefine hash indices.
Definition: pede.f90:6814
subroutine pargrp(inds, inde)
Parameter group info update for block of parameters.
Definition: pede.f90:3276
subroutine prtglo
Print final log file.
Definition: pede.f90:5426
subroutine monres
Monitor input residuals.
Definition: pede.f90:8653
subroutine intext(text, nline)
Interprete text.
Definition: pede.f90:12106
integer(mpl) function ijadd(itema, itemb)
Index for sparse storage (custom).
Definition: pede.f90:6447
subroutine mdiags
Solution by diagonalization.
Definition: pede.f90:9958
program mptwo
Millepede II main program Pede.
Definition: pede.f90:917
subroutine prtstat
Print input statistic.
Definition: pede.f90:5613
real(mpd) function matij(itema, itemb)
Get matrix element at (i,j).
Definition: pede.f90:6554
subroutine grpcon
Group constraints.
Definition: pede.f90:1663
subroutine loopbf(nrej, numfil, naccf, chi2f, ndff)
Loop over records in read buffer (block), fits and sums.
Definition: pede.f90:4354
subroutine peread(more)
Read (block of) records from binary files.
Definition: pede.f90:2597
subroutine filetx
Interprete text files.
Definition: pede.f90:11783
integer(mpi) function iprime(n)
largest prime number < N.
Definition: pede.f90:6916
subroutine ploopc(lunp)
Print sub-iteration line.
Definition: pede.f90:3936
integer(mpl) function ijcsr3(itema, itemb)
Index for sparse storage (CSR3).
Definition: pede.f90:6496
subroutine useone
Make usable (sort items and redefine hash indices).
Definition: pede.f90:6884
subroutine mvopen(lun, fname)
Open file.
Definition: pede.f90:13155
subroutine chkrej
Check rejection details.
Definition: pede.f90:11243
subroutine avprd0(n, l, x, b)
Product symmetric (sub block) matrix times vector.
Definition: pede.f90:6018
subroutine addsums(ithrd, chi2, ndf, dw)
Accurate summation.
Definition: pede.f90:13552
subroutine solgloqlp(ivgbi)
Error for single global parameter from MINRES-QLP.
Definition: pede.f90:1506
subroutine lpqldec(a, emin, emax)
QL decomposition.
Definition: pede.f90:9510
subroutine addcst
Add constraint information to matrix and vector.
Definition: pede.f90:1589
subroutine petime
Print times.
Definition: pede.f90:13192
subroutine mstart(text)
Start of 'module' printout.
Definition: pede.f90:13102
subroutine mend
End of 'module' printout.
Definition: pede.f90:13138
subroutine anasps
Analyse sparsity structure.
Definition: pede.f90:6186
subroutine minver
Solution by matrix inversion.
Definition: pede.f90:8957
subroutine peprep(mode)
Prepare records.
Definition: pede.f90:2949
integer(mpi) function ijprec(itema, itemb)
Precision for storage of parameter groups.
Definition: pede.f90:6418
subroutine explfc(lunit)
Print explanation of iteration table.
Definition: pede.f90:4010
subroutine getsums(chi2, ndf, wndf)
Get accurate sums.
Definition: pede.f90:13585
subroutine chkmat
Check global matrix.
Definition: pede.f90:13506
subroutine binopn(kfile, ithr, ierr)
Open binary file.
Definition: pede.f90:13264
subroutine pepgrp
Parameter group info update.
Definition: pede.f90:3122
subroutine sechms(deltat, nhour, minut, secnd)
Time conversion.
Definition: pede.f90:6699
integer(mpi) function inone(item)
Translate labels to indices (for global parameters).
Definition: pede.f90:6744
subroutine avprds(n, l, x, is, ie, b)
Product symmetric (sub block) matrix times sparse vector.
Definition: pede.f90:5804
subroutine avprod(n, x, b)
Product symmetric matrix times vector.
Definition: pede.f90:6280
subroutine ijpgrp(itema, itemb, ij, lr, iprc)
Index (region length and precision) for sparse storage of parameter groups.
Definition: pede.f90:6320
subroutine loop1i
Iteration of first data loop.
Definition: pede.f90:7319
subroutine mhalf2
Fill 2nd half of matrix for extended storage.
Definition: pede.f90:6612
subroutine ckpgrp
Check (rank of) parameter groups.
Definition: pede.f90:13426
subroutine additemi(length, list, label, ivalue)
add item to list
Definition: pede.f90:13067
subroutine mminrsqlp
Solution with MINRES-QLP.
Definition: pede.f90:10242
subroutine filetc
Interprete command line option, steering file.
Definition: pede.f90:11307
subroutine feasib(concut, iact)
Make parameters feasible.
Definition: pede.f90:2436
subroutine mspardiso
Solution with Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO.
Definition: pede.f90:9729
subroutine mdutrf
Solution by factorization.
Definition: pede.f90:9329
subroutine mdptrf
Solution by factorization.
Definition: pede.f90:9182
subroutine mvsolv(n, x, y)
Solution for finite band width preconditioner.
Definition: pede.f90:10369
subroutine vmprep(msize)
Prepare storage for vectors and matrices.
Definition: pede.f90:8760
subroutine ploopd(lunp)
Print solution line.
Definition: pede.f90:3984
subroutine pechk(ibuf, nerr)
Check Millepede record.
Definition: pede.f90:3050
subroutine loop2
Second data loop (number of derivatives, global label pairs).
Definition: pede.f90:7431
integer(mpi) function nufile(fname)
Inquire on file.
Definition: pede.f90:12049
subroutine additemc(length, list, label, text)
add character item to list
Definition: pede.f90:13025
void resetc(int nFileIn)
Rewind file.
Definition: readc.c:185
void initc(int nFiles)
Initialises the 'global' variables used for file handling.
Definition: readc.c:91
void closec(int nFileIn)
Close file.
Definition: readc.c:168
void readc(double *bufferDouble, float *bufferFloat, int *bufferInt, int *lengthBuffers, int nFileIn, int *errorFlag)
Read record from file.
Definition: readc.c:219
void openc(const char *fileName, int lfn, int nFileIn, int *errorFlag)
Open file.
Definition: readc.c:110
list items from steering file
Definition: mpdef.f90:40
character list items from steering file
Definition: mpdef.f90:47
integer list items from steering file
Definition: mpdef.f90:52