Millepede-II V04-17-03
pede.f90
Go to the documentation of this file.
1! Code converted using TO_F90 by Alan Miller
2! Date: 2012-03-16 Time: 11:06:00
3
27
275
562
563
823
861
904
905#ifdef SCOREP_USER_ENABLE
906#include "scorep/SCOREP_User.inc"
907#endif
908
910PROGRAM mptwo
911 USE mpmod
912 USE mpdalc
913 USE mptest1, ONLY: nplan,del,dvd
914 USE mptest2, ONLY: nlyr,nmx,nmy,sdevx,sdevy,ntot
915
916 IMPLICIT NONE
917 REAL(mps) :: andf
918 REAL(mps) :: c2ndf
919 REAL(mps) :: deltat
920 REAL(mps) :: diff
921 REAL(mps) :: err
922 REAL(mps) :: gbu
923 REAL(mps) :: gmati
924 REAL(mps) :: rej
925 REAL :: rloop1
926 REAL :: rloop2
927 REAL :: rstext
928 REAL(mps) :: secnd
929 REAL :: rst
930 REAL :: rstp
931 REAL, DIMENSION(2) :: ta
932 INTEGER(mpi) :: i
933 INTEGER(mpi) :: ii
934 INTEGER(mpi) :: iopnmp
935 INTEGER(mpi) :: ix
936 INTEGER(mpi) :: ixv
937 INTEGER(mpi) :: iy
938 INTEGER(mpi) :: k
939 INTEGER(mpi) :: kfl
940 INTEGER(mpi) :: lun
941 INTEGER :: minut
942 INTEGER :: nhour
943 INTEGER(mpi) :: nmxy
944 INTEGER(mpi) :: nrc
945 INTEGER(mpi) :: nsecnd
946 INTEGER(mpi) :: ntsec
947
948 CHARACTER (LEN=24) :: chdate
949 CHARACTER (LEN=24) :: chost
950#ifdef LAPACK64
951 CHARACTER (LEN=6) :: c6
952 INTEGER major, minor, patch
953#endif
954
955 INTEGER(mpl) :: rows
956 INTEGER(mpl) :: cols
957
958 REAL(mpd) :: sums(9)
959 !$ INTEGER(mpi) :: OMP_GET_NUM_PROCS,OMP_GET_MAX_THREADS
960 !$ INTEGER(mpi) :: MXTHRD
961 !$ INTEGER(mpi) :: NPROC
962
963 REAL etime
964
965 SAVE
966 ! ...
967 rstp=etime(ta)
968 CALL fdate(chdate)
969
970 ! millepede monitoring file
971 lunmon=0
972 ! millepede.log file
973 lunlog=8
974 lvllog=1
975 CALL mvopen(lunlog,'millepede.log')
976 CALL getenv('HOSTNAME',chost)
977 IF (chost(1:1) == ' ') CALL getenv('HOST',chost)
978 WRITE(*,*) '($Id: 2abb4a313debe0a8077a24e1c46a3c0875f9041b $)'
979 iopnmp=0
980 !$ iopnmp=1
981 !$ WRITE(*,*) 'using OpenMP (TM)'
982#ifdef LAPACK64
983 CALL ilaver( major,minor, patch )
984 WRITE(*,110) lapack64, major,minor, patch
985110 FORMAT(' using LAPACK64 with ',(a),', version ',i0,'.',i0,'.',i0)
986#ifdef PARDISO
987 WRITE(*,*) 'using Intel oneMKL PARDISO'
988#endif
989#endif
990#ifdef __GFORTRAN__
991 WRITE(*,111) __gnuc__ , __gnuc_minor__ , __gnuc_patchlevel__
992111 FORMAT(' compiled with gcc ',i0,'.',i0,'.',i0)
993#endif
994#ifdef __PGIC__
995 WRITE(*,111) __pgic__ , __pgic_minor__ , __pgic_patchlevel__
996111 FORMAT(' compiled with pgi ',i0,'.',i0,'.',i0)
997#endif
998#ifdef SCOREP_USER_ENABLE
999 WRITE(*,*) 'instrumenting Score-P user regions'
1000#endif
1001 WRITE(*,*) ' '
1002 WRITE(*,*) ' < Millepede II-P starting ... ',chdate
1003 WRITE(*,*) ' ',chost
1004 WRITE(*,*) ' '
1005
1006 WRITE(8,*) '($Id: 2abb4a313debe0a8077a24e1c46a3c0875f9041b $)'
1007 WRITE(8,*) ' '
1008 WRITE(8,*) 'Log-file Millepede II-P ', chdate
1009 WRITE(8,*) ' ', chost
1010
1011 CALL peend(-1,'Still running or crashed')
1012 ! read command line and text files
1013
1014 CALL filetc ! command line and steering file analysis
1015 CALL filetx ! read text files
1016 ! dummy call for dynamic memory allocation
1017 CALL gmpdef(0,nfilb,'dummy call')
1018
1019 IF (icheck > 0) THEN
1020 WRITE(*,*) '!!! Checking input only, no calculation of a solution !!!'
1021 WRITE(8,*) '!!! Checking input only, no calculation of a solution !!!'
1022 END IF
1023 lvllog=mprint ! export print level
1024 IF (memdbg > 0) printflagalloc=1 ! debug memory management
1025 !$ WRITE(*,*)
1026 !$ NPROC=1
1027 !$ MXTHRD=1
1028 !$ NPROC=OMP_GET_NUM_PROCS() ! number of processors available
1029 !$ CALL OMP_SET_NUM_THREADS(MTHRD) ! set max number of threads to MTHRD
1030 !$ MXTHRD=OMP_GET_MAX_THREADS() ! get max number of threads back
1031 !$ WRITE(*,*) 'Number of processors available: ', NPROC
1032 !$ WRITE(*,*) 'Maximum number of OpenMP threads: ', MXTHRD
1033 !$ WRITE(*,*) 'Number of threads for processing: ', MTHRD
1034 !$ IF (MXREC.GT.0) MTHRDR=1 ! to get allways the same MXREC records
1035 !$ IF (ICHECK.GT.1) MTHRDR=1 ! to get allways the same order of records
1036 !$ WRITE(*,*) 'Number of threads for reading: ', MTHRDR
1037 !$POMP INST INIT ! start profiling with ompP
1038#ifdef LAPACK64
1039 IF(iopnmp > 0) THEN
1040 CALL getenv('OMP_NUM_THREADS',c6)
1041 ELSE
1042 CALL getenv(lapack64//'_NUM_THREADS',c6)
1043 END IF
1044 IF (c6(1:1) == ' ') THEN
1045 IF(iopnmp > 0) THEN
1046 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty OMP_NUM_THREADS)'
1047 ELSE
1048 WRITE(*,*) 'Number of threads for LAPACK: unkown (empty ',lapack64//'_NUM_THREADS)'
1049 END IF
1050 ELSE
1051 WRITE(*,*) 'Number of threads for LAPACK: ', c6
1052 END IF
1053#endif
1054 cols=mthrd
1055 CALL mpalloc(globalchi2sumd,cols,'fractional part of Chi2 sum')
1056 globalchi2sumd=0.0_mpd
1057 CALL mpalloc(globalchi2sumi,cols,'integer part of Chi2 sum')
1058 globalchi2sumi=0_mpl
1059 CALL mpalloc(globalndfsum,cols,'NDF sum')
1060 globalndfsum=0_mpl
1061 CALL mpalloc(globalndfsumw,cols,'weighted NDF sum')
1062 globalndfsumw=0.0_mpd
1063
1064 IF (ncache < 0) THEN
1065 ncache=25000000*mthrd ! default cache size (100 MB per thread)
1066 ENDIF
1067 rows=6; cols=mthrdr
1068 CALL mpalloc(readbufferinfo,rows,cols,'read buffer header')
1069 ! histogram file
1070 lun=7
1071 CALL mvopen(lun,'millepede.his')
1072 CALL hmplun(lun) ! unit for histograms
1073 CALL gmplun(lun) ! unit for xy data
1074
1075 ! debugging
1076 IF(nrecpr /= 0.OR.nrecp2 /= 0) THEN
1077 CALL mvopen(1,'mpdebug.txt')
1078 END IF
1079
1080 rstext=etime(ta)
1081 times(0)=rstext-rstp ! time for text processing
1082
1083 ! preparation of data sub-arrays
1084
1085 CALL loop1
1086 rloop1=etime(ta)
1087 times(1)=rloop1-rstext ! time for LOOP1
1088
1089 CALL loop2
1090 IF(chicut /= 0.0) THEN
1091 WRITE(8,*) 'Chi square cut equiv 3 st.dev applied ...'
1092 WRITE(8,*) ' in first iteration with factor',chicut
1093 WRITE(8,*) ' in second iteration with factor',chirem
1094 WRITE(8,*) ' (reduced by sqrt in next iterations)'
1095 END IF
1096
1097 IF(lhuber /= 0) THEN
1098 WRITE(8,*) 'Down-weighting of outliers in', lhuber,' iterations'
1099 WRITE(8,*) 'Cut on downweight fraction',dwcut
1100 END IF
1101
1102 rloop2=etime(ta)
1103 times(2)=rloop2-rloop1 ! time for LOOP2
1104
1105 IF(icheck > 0) THEN
1106 CALL prtstat
1107 IF (ncgbe < 0) THEN
1108 CALL peend(5,'Ended without solution (empty constraints)')
1109 ELSE
1110 CALL peend(0,'Ended normally')
1111 END IF
1112 GOTO 99 ! only checking input
1113 END IF
1114
1115 ! use different solution methods
1116
1117 CALL mstart('Iteration') ! Solution module starting
1118
1119 CALL xloopn ! all methods
1120
1121 ! ------------------------------------------------------------------
1122
1123 IF(nloopn > 2.AND.nhistp /= 0) THEN ! last iteration
1124 CALL hmprnt(3) ! scaled residual of single measurement (with global deriv.)
1125 CALL hmprnt(12) ! scaled residual of single measurement (no global deriv.)
1126 CALL hmprnt(4) ! chi^2/Ndf
1127 END IF
1128 IF(nloopn > 2) THEN
1129 CALL hmpwrt(3)
1130 CALL hmpwrt(12)
1131 CALL hmpwrt(4)
1132 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
1133 IF (nloopn <= lfitnp) THEN
1134 CALL hmpwrt(13)
1135 CALL hmpwrt(14)
1136 CALL gmpwrt(5)
1137 END IF
1138 END IF
1139 IF(nhistp /= 0) THEN
1140 CALL gmprnt(1)
1141 CALL gmprnt(2)
1142 END IF
1143 CALL gmpwrt(1) ! output of xy data
1144 CALL gmpwrt(2) ! output of xy data
1145 ! 'track quality' per binary file
1146 IF (nfilb > 1) THEN
1147 CALL gmpdef(6,1,'log10(#records) vs file number')
1148 CALL gmpdef(7,1,'final rejection fraction vs file number')
1149 CALL gmpdef(8,1, &
1150 'final <Chi^2/Ndf> from accepted local fits vs file number')
1151 CALL gmpdef(9,1, '<Ndf> from accepted local fits vs file number')
1152
1153 DO i=1,nfilb
1154 kfl=kfd(2,i)
1155 nrc=-kfd(1,i)
1156 IF (nrc > 0) THEN
1157 rej=real(nrc-jfd(kfl),mps)/real(nrc,mps)
1158 CALL gmpxy(6,real(kfl,mps),log10(real(nrc,mps))) ! log10(#records) vs file
1159 CALL gmpxy(7,real(kfl,mps),rej) ! rejection fraction vs file
1160 END IF
1161 IF (jfd(kfl) > 0) THEN
1162 c2ndf=cfd(kfl)/real(jfd(kfl),mps)
1163 CALL gmpxy(8,real(kfl,mps),c2ndf) ! <Chi2/NDF> vs file
1164 andf=real(dfd(kfl),mps)/real(jfd(kfl),mps)
1165 CALL gmpxy(9,real(kfl,mps),andf) ! <NDF> vs file
1166 END IF
1167 END DO
1168 IF(nhistp /= 0) THEN
1169 CALL gmprnt(6)
1170 CALL gmprnt(7)
1171 CALL gmprnt(8)
1172 CALL gmprnt(9)
1173 END IF
1174 CALL gmpwrt(6) ! output of xy data
1175 CALL gmpwrt(7) ! output of xy data
1176 CALL gmpwrt(8) ! output of xy data
1177 CALL gmpwrt(9) ! output of xy data
1178 END IF
1179
1180 IF(ictest == 1) THEN
1181 WRITE(*,*) ' '
1182 WRITE(*,*) 'Misalignment test wire chamber'
1183 WRITE(*,*) ' '
1184
1185 CALL hmpdef( 9,-0.0015,+0.0015,'True - fitted displacement')
1186 CALL hmpdef(10,-0.0015,+0.0015,'True - fitted Vdrift')
1187 DO i=1,4
1188 sums(i)=0.0_mpd
1189 END DO
1190 DO i=1,nplan
1191 diff=real(-del(i)-globalparameter(i),mps)
1192 sums(1)=sums(1)+diff
1193 sums(2)=sums(2)+diff*diff
1194 diff=real(-dvd(i)-globalparameter(100+i),mps)
1195 sums(3)=sums(3)+diff
1196 sums(4)=sums(4)+diff*diff
1197 END DO
1198 sums(1)=0.01_mpd*sums(1)
1199 sums(2)=sqrt(0.01_mpd*sums(2))
1200 sums(3)=0.01_mpd*sums(3)
1201 sums(4)=sqrt(0.01_mpd*sums(4))
1202 WRITE(*,143) 'Parameters 1 - 100: mean =',sums(1), 'rms =',sums(2)
1203 WRITE(*,143) 'Parameters 101 - 200: mean =',sums(3), 'rms =',sums(4)
1204143 FORMAT(6x,a28,f9.6,3x,a5,f9.6)
1205 WRITE(*,*) ' '
1206 WRITE(*,*) ' '
1207 WRITE(*,*) ' I label simulated fitted diff'
1208 WRITE(*,*) ' -------------------------------------------- '
1209 DO i=1,100
1210 WRITE(*,102) i,globalparlabelindex(1,i),-del(i),globalparameter(i),-del(i)-globalparameter(i)
1211 diff=real(-del(i)-globalparameter(i),mps)
1212 CALL hmpent( 9,diff)
1213 END DO
1214 DO i=101,200
1215 WRITE(*,102) i,globalparlabelindex(1,i),-dvd(i-100),globalparameter(i),-dvd(i-100)-globalparameter(i)
1216 diff=real(-dvd(i-100)-globalparameter(i),mps)
1217 CALL hmpent(10,diff)
1218 END DO
1219 IF(nhistp /= 0) THEN
1220 CALL hmprnt( 9)
1221 CALL hmprnt(10)
1222 END IF
1223 CALL hmpwrt( 9)
1224 CALL hmpwrt(10)
1225 END IF
1226 IF(ictest > 1) THEN
1227 WRITE(*,*) ' '
1228 WRITE(*,*) 'Misalignment test Si tracker'
1229 WRITE(*,*) ' '
1230
1231 CALL hmpdef( 9,-0.0025,+0.0025,'True - fitted displacement X')
1232 CALL hmpdef(10,-0.025,+0.025,'True - fitted displacement Y')
1233 DO i=1,9
1234 sums(i)=0.0_mpd
1235 END DO
1236 nmxy=nmx*nmy
1237 ix=0
1238 iy=ntot
1239 DO i=1,nlyr
1240 DO k=1,nmxy
1241 ix=ix+1
1242 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1243 sums(1)=sums(1)+1.0_mpd
1244 sums(2)=sums(2)+diff
1245 sums(3)=sums(3)+diff*diff
1246 ixv=globalparlabelindex(2,ix)
1247 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1248 ii=(ixv*ixv+ixv)/2
1249 gmati=real(globalmatd(ii),mps)
1250 err=sqrt(abs(gmati))
1251 diff=diff/err
1252 sums(7)=sums(7)+1.0_mpd
1253 sums(8)=sums(8)+diff
1254 sums(9)=sums(9)+diff*diff
1255 END IF
1256 END DO
1257 IF (mod(i,3) == 1) THEN
1258 DO k=1,nmxy
1259 iy=iy+1
1260 diff=-real(sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1261 sums(4)=sums(4)+1.0_mpd
1262 sums(5)=sums(5)+diff
1263 sums(6)=sums(6)+diff*diff
1264 ixv=globalparlabelindex(2,iy)
1265 IF (ixv > 0.AND.metsol == 1.OR.metsol == 2) THEN
1266 ii=(ixv*ixv+ixv)/2
1267 gmati=real(globalmatd(ii),mps)
1268 err=sqrt(abs(gmati))
1269 diff=diff/err
1270 sums(7)=sums(7)+1.0_mpd
1271 sums(8)=sums(8)+diff
1272 sums(9)=sums(9)+diff*diff
1273 END IF
1274 END DO
1275 END IF
1276 END DO
1277 sums(2)=sums(2)/sums(1)
1278 sums(3)=sqrt(sums(3)/sums(1))
1279 sums(5)=sums(5)/sums(4)
1280 sums(6)=sqrt(sums(6)/sums(4))
1281 WRITE(*,143) 'Parameters 1 - 500: mean =',sums(2), 'rms =',sums(3)
1282 WRITE(*,143) 'Parameters 501 - 700: mean =',sums(5), 'rms =',sums(6)
1283 IF (sums(7) > 0.5_mpd) THEN
1284 sums(8)=sums(8)/sums(7)
1285 sums(9)=sqrt(sums(9)/sums(7))
1286 WRITE(*,143) 'Parameter pulls, all: mean =',sums(8), 'rms =',sums(9)
1287 END IF
1288 WRITE(*,*) ' '
1289 WRITE(*,*) ' '
1290 WRITE(*,*) ' I label simulated fitted diff'
1291 WRITE(*,*) ' -------------------------------------------- '
1292 ix=0
1293 iy=ntot
1294 DO i=1,nlyr
1295 DO k=1,nmxy
1296 ix=ix+1
1297 diff=real(-sdevx((i-1)*nmxy+k)-globalparameter(ix),mps)
1298 CALL hmpent( 9,diff)
1299 WRITE(*,102) ix,globalparlabelindex(1,ix),-sdevx((i-1)*nmxy+k),globalparameter(ix),-diff
1300 END DO
1301 END DO
1302 DO i=1,nlyr
1303 IF (mod(i,3) == 1) THEN
1304 DO k=1,nmxy
1305 iy=iy+1
1306 diff=real(-sdevy((i-1)*nmxy+k)-globalparameter(iy),mps)
1307 CALL hmpent(10,diff)
1308 WRITE(*,102) iy,globalparlabelindex(1,iy),-sdevy((i-1)*nmxy+k),globalparameter(iy),-diff
1309 END DO
1310 END IF
1311 END DO
1312 IF(nhistp /= 0) THEN
1313 CALL hmprnt( 9)
1314 CALL hmprnt(10)
1315 END IF
1316 CALL hmpwrt( 9)
1317 CALL hmpwrt(10)
1318 END IF
1319
1320 IF(nrec1+nrec2 > 0) THEN
1321 WRITE(8,*) ' '
1322 IF(nrec1 > 0) THEN
1323 WRITE(8,*) 'Record',nrec1,' has largest residual:',value1
1324 END IF
1325 IF(nrec2 > 0) THEN
1326 WRITE(8,*) 'Record',nrec2,' has largest Chi^2/Ndf:',value2
1327 END IF
1328 END IF
1329 IF(nrec3 < huge(nrec3)) THEN
1330 WRITE(8,*) 'Record',nrec3, ' is first with error (rank deficit/NaN)'
1331 END IF
133299 WRITE(8,*) ' '
1333 IF (iteren > mreqenf) THEN
1334 WRITE(8,*) 'In total 3 +',nloopn,' loops through the data files'
1335 ELSE
1336 WRITE(8,*) 'In total 2 +',nloopn,' loops through the data files'
1337 ENDIF
1338 IF (mnrsit > 0) THEN
1339 WRITE(8,*) ' '
1340 WRITE(8,*) 'In total ',mnrsit,' internal MINRES iterations'
1341 END IF
1342
1343 WRITE(8,103) times(0),times(1),times(2),times(4),times(7), &
1344 times(5),times(8),times(3),times(6)
1345
1346 rst=etime(ta)
1347 deltat=rst-rstp
1348 ntsec=nint(deltat,mpi)
1349 CALL sechms(deltat,nhour,minut,secnd)
1350 nsecnd=nint(secnd,mpi) ! round
1351 WRITE(8,*) 'Total time =',ntsec,' seconds =',nhour,' h',minut, &
1352 ' m',nsecnd,' seconds'
1353 CALL fdate(chdate)
1354 WRITE(8,*) 'end ', chdate
1355 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1356 WRITE(8,*) ' '
1357 WRITE(8,105) gbu
1358
1359 ! Rejects ----------------------------------------------------------
1360
1361 IF(sum(nrejec) /= 0) THEN
1362 WRITE(8,*) ' '
1363 WRITE(8,*) 'Data records rejected in last iteration: '
1364 CALL prtrej(8)
1365 WRITE(8,*) ' '
1366 END IF
1367 IF (icheck <= 0) CALL explfc(8)
1368
1369 WRITE(*,*) ' '
1370 WRITE(*,*) ' < Millepede II-P ending ... ', chdate ! with exit code',ITEXIT,' >'
1371 WRITE(*,*) ' '
1372 gbu=1.0e-9*real(maxwordsalloc*(bit_size(1_mpi)/8),mps) ! GB used
1373 WRITE(*,105) gbu
1374#ifdef LAPACK64
1375#ifdef PARDISO
1376 IF(ipdmem > 0) WRITE(*,106) real(ipdmem,mps)*1.e-6
1377106 FORMAT(' PARDISO dyn. memory allocation: ',f11.6,' GB')
1378#endif
1379#endif
1380 WRITE(*,*) ' '
1381 ! close files
1382 CLOSE(unit=7) ! histogram file
1383 CLOSE(unit=8) ! log file
1384
1385 ! post processing?
1386 IF (lenpostproc > 0) THEN
1387 WRITE(*,*) 'Postprocessing:'
1388 IF (lenpostproc >= 80) THEN
1389 WRITE(*,*) cpostproc(1:38) // ' .. ' // cpostproc(lenpostproc-37:lenpostproc)
1390 ELSE
1391 WRITE(*,*) cpostproc(1:lenpostproc)
1392 ENDIF
1393 WRITE(*,*) ' '
1394 CALL system(cpostproc(1:lenpostproc))
1395 END IF
1396
1397102 FORMAT(2x,i4,i10,2x,3f10.5)
1398103 FORMAT(' Times [in sec] for text processing',f12.3/ &
1399 ' LOOP1',f12.3/ &
1400 ' LOOP2',f12.3/ &
1401 ' func. value ',f12.3,' *',f4.0/ &
1402 ' func. value, global matrix, solution',f12.3,' *',f4.0/ &
1403 ' new solution',f12.3,' *',f4.0/)
1404105 FORMAT(' Peak dynamic memory allocation: ',f11.6,' GB')
1405END PROGRAM mptwo ! Mille
1406
1413
1414SUBROUTINE solglo(ivgbi)
1415 USE mpmod
1416 USE minresmodule, ONLY: minres
1417
1418 IMPLICIT NONE
1419 REAL(mps) :: par
1420 REAL(mps) :: dpa
1421 REAL(mps) :: err
1422 REAL(mps) :: gcor2
1423 INTEGER(mpi) :: iph
1424 INTEGER(mpi) :: istop
1425 INTEGER(mpi) :: itgbi
1426 INTEGER(mpi) :: itgbl
1427 INTEGER(mpi) :: itn
1428 INTEGER(mpi) :: itnlim
1429 INTEGER(mpi) :: nout
1430
1431 INTEGER(mpi), INTENT(IN) :: ivgbi
1432
1433 REAL(mpd) :: shift
1434 REAL(mpd) :: rtol
1435 REAL(mpd) :: anorm
1436 REAL(mpd) :: acond
1437 REAL(mpd) :: arnorm
1438 REAL(mpd) :: rnorm
1439 REAL(mpd) :: ynorm
1440 REAL(mpd) :: gmati
1441 REAL(mpd) :: diag
1442 REAL(mpd) :: matij
1443 LOGICAL :: checka
1444 EXTERNAL avprod, mcsolv, mvsolv
1445 SAVE
1446 DATA iph/0/
1447 ! ...
1448 IF(iph == 0) THEN
1449 iph=1
1450 WRITE(*,101)
1451 END IF
1452 itgbi=globalparvartototal(ivgbi)
1453 itgbl=globalparlabelindex(1,itgbi)
1454
1455 globalvector=0.0_mpd ! reset rhs vector IGVEC
1456 globalvector(ivgbi)=1.0_mpd
1457
1458 ! NOUT =6
1459 nout =0
1460 itnlim=200
1461 shift =0.0_mpd
1462 rtol = mrestl ! from steering
1463 checka=.false.
1464
1465
1466 IF(mbandw == 0) THEN ! default preconditioner
1467 CALL minres(nagb, avprod, mcsolv, globalvector, shift, checka ,.true. , &
1468 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1469
1470 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1471 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.true. , &
1472 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1473 ELSE
1474 CALL minres(nagb, avprod, mvsolv, globalvector, shift, checka ,.false. , &
1475 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
1476 END IF
1477
1478 par=real(globalparameter(itgbi),mps)
1479 dpa=real(par-globalparstart(itgbi),mps)
1480 gmati=globalcorrections(ivgbi)
1481 err=sqrt(abs(real(gmati,mps)))
1482 IF(gmati < 0.0_mpd) err=-err
1483 diag=matij(ivgbi,ivgbi)
1484 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1485 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1486101 FORMAT(1x,' label parameter presigma differ', &
1487 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1488102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1489END SUBROUTINE solglo
1490
1497
1498SUBROUTINE solgloqlp(ivgbi)
1499 USE mpmod
1500 USE minresqlpmodule, ONLY: minresqlp
1501
1502 IMPLICIT NONE
1503 REAL(mps) :: par
1504 REAL(mps) :: dpa
1505 REAL(mps) :: err
1506 REAL(mps) :: gcor2
1507 INTEGER(mpi) :: iph
1508 INTEGER(mpi) :: istop
1509 INTEGER(mpi) :: itgbi
1510 INTEGER(mpi) :: itgbl
1511 INTEGER(mpi) :: itn
1512 INTEGER(mpi) :: itnlim
1513 INTEGER(mpi) :: nout
1514
1515 INTEGER(mpi), INTENT(IN) :: ivgbi
1516
1517 REAL(mpd) :: shift
1518 REAL(mpd) :: rtol
1519 REAL(mpd) :: mxxnrm
1520 REAL(mpd) :: trcond
1521 REAL(mpd) :: gmati
1522 REAL(mpd) :: diag
1523 REAL(mpd) :: matij
1524
1525 EXTERNAL avprod, mcsolv, mvsolv
1526 SAVE
1527 DATA iph/0/
1528 ! ...
1529 IF(iph == 0) THEN
1530 iph=1
1531 WRITE(*,101)
1532 END IF
1533 itgbi=globalparvartototal(ivgbi)
1534 itgbl=globalparlabelindex(1,itgbi)
1535
1536 globalvector=0.0_mpd ! reset rhs vector IGVEC
1537 globalvector(ivgbi)=1.0_mpd
1538
1539 ! NOUT =6
1540 nout =0
1541 itnlim=200
1542 shift =0.0_mpd
1543 rtol = mrestl ! from steering
1544 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
1545 IF(mrmode == 1) THEN
1546 trcond = 1.0_mpd/epsilon(trcond) ! only QR
1547 ELSE IF(mrmode == 2) THEN
1548 trcond = 1.0_mpd ! only QLP
1549 ELSE
1550 trcond = mrtcnd ! QR followed by QLP
1551 END IF
1552
1553 IF(mbandw == 0) THEN ! default preconditioner
1554 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mcsolv, nout=nout, &
1555 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1556 x=globalcorrections, istop=istop, itn=itn)
1557 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
1558 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, msolve=mvsolv, nout=nout, &
1559 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1560 x=globalcorrections, istop=istop, itn=itn)
1561 ELSE
1562 CALL minresqlp( n=nagb, aprod=avprod, b=globalvector, nout=nout, &
1563 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
1564 x=globalcorrections, istop=istop, itn=itn)
1565 END IF
1566
1567 par=real(globalparameter(itgbi),mps)
1568 dpa=real(par-globalparstart(itgbi),mps)
1569 gmati=globalcorrections(ivgbi)
1570 err=sqrt(abs(real(gmati,mps)))
1571 IF(gmati < 0.0_mpd) err=-err
1572 diag=matij(ivgbi,ivgbi)
1573 gcor2=real(1.0_mpd-1.0_mpd/(gmati*diag),mps) ! global correlation (squared)
1574 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor2,itn
1575101 FORMAT(1x,' label parameter presigma differ', &
1576 ' Error gcor^2 iit'/ 1x,'---------',2x,5('-----------'),2x,'----')
1577102 FORMAT(i10,2x,4g12.4,f7.4,i6,i4)
1578END SUBROUTINE solgloqlp
1579
1581SUBROUTINE addcst
1582 USE mpmod
1583
1584 IMPLICIT NONE
1585 REAL(mpd) :: climit
1586 REAL(mpd) :: factr
1587 REAL(mpd) :: sgm
1588
1589 INTEGER(mpi) :: i
1590 INTEGER(mpi) :: icgb
1591 INTEGER(mpi) :: irhs
1592 INTEGER(mpi) :: itgbi
1593 INTEGER(mpi) :: ivgb
1594 INTEGER(mpi) :: j
1595 INTEGER(mpi) :: jcgb
1596 INTEGER(mpi) :: l
1597 INTEGER(mpi) :: label
1598 INTEGER(mpi) :: nop
1599 INTEGER(mpi) :: inone
1600
1601 REAL(mpd) :: rhs
1602 REAL(mpd) :: drhs(4)
1603 INTEGER(mpi) :: idrh (4)
1604 SAVE
1605 ! ...
1606 nop=0
1607 IF(lenconstraints == 0) RETURN ! no constraints
1608 climit=1.0e-5 ! limit for printout
1609 irhs=0 ! number of values in DRHS(.), to be printed
1610
1611 DO jcgb=1,ncgb
1612 icgb=matconssort(3,jcgb) ! unsorted constraint index
1613 i=vecconsstart(icgb)
1614 rhs=listconstraints(i )%value ! right hand side
1615 sgm=listconstraints(i+1)%value ! sigma parameter
1616 DO j=i+2,vecconsstart(icgb+1)-1
1617 label=listconstraints(j)%label
1618 factr=listconstraints(j)%value
1619 itgbi=inone(label) ! -> ITGBI= index of parameter label
1620 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
1621
1622 IF(icalcm == 1.AND.nagb > nvgb.AND.ivgb > 0) THEN
1623 CALL mupdat(nvgb+jcgb,ivgb,factr) ! add to matrix
1624 END IF
1625
1626 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
1627 END DO
1628 IF(abs(rhs) > climit) THEN
1629 irhs=irhs+1
1630 idrh(irhs)=jcgb
1631 drhs(irhs)=rhs
1632 nop=1
1633 IF(irhs == 4) THEN
1634 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1635 irhs=0
1636 END IF
1637 END IF
1638 vecconsresiduals(jcgb)=rhs
1639 IF (nagb > nvgb) globalvector(nvgb+jcgb)=rhs
1640 END DO
1641
1642 IF(irhs /= 0) THEN
1643 WRITE(*,101) (idrh(l),drhs(l),l=1,irhs)
1644 END IF
1645 IF(nop == 0) RETURN
1646 WRITE(*,102) ' Constraints: only equation values >', climit,' are printed'
1647101 FORMAT(' ',4(i6,g11.3))
1648102 FORMAT(a,g11.2,a)
1649END SUBROUTINE addcst
1650
1655SUBROUTINE grpcon
1656 USE mpmod
1657 USE mpdalc
1658
1659 IMPLICIT NONE
1660 INTEGER(mpi) :: i
1661 INTEGER(mpi) :: icgb
1662 INTEGER(mpi) :: icgrp
1663 INTEGER(mpi) :: ioff
1664 INTEGER(mpi) :: itgbi
1665 INTEGER(mpi) :: j
1666 INTEGER(mpi) :: jcgb
1667 INTEGER(mpi) :: label
1668 INTEGER(mpi) :: labelf
1669 INTEGER(mpi) :: labell
1670 INTEGER(mpi) :: last
1671 INTEGER(mpi) :: line1
1672 INTEGER(mpi) :: ncon
1673 INTEGER(mpi) :: ndiff
1674 INTEGER(mpi) :: npar
1675 INTEGER(mpi) :: inone
1676 INTEGER(mpi) :: itype
1677 INTEGER(mpi) :: ncgbd
1678 INTEGER(mpi) :: ncgbr
1679 INTEGER(mpi) :: ncgbw
1680 INTEGER(mpi) :: ncgrpd
1681 INTEGER(mpi) :: ncgrpr
1682 INTEGER(mpi) :: next
1683
1684 INTEGER(mpl):: length
1685 INTEGER(mpl) :: rows
1686
1687 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsOffsets
1688 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecParConsList
1689 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParOffsets
1690 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsParList
1691 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1692
1693 ncgb=0
1694 ncgbw=0
1695 IF(lenconstraints == 0) RETURN ! no constraints
1696
1697 i=0
1698 last=0
1699 itype=0
1700 ! find next constraint header and count nr of constraints
1701 DO WHILE(i < lenconstraints)
1702 i=i+1
1703 label=listconstraints(i)%label
1704 IF(last < 0.AND.label < 0) THEN
1705 ncgb=ncgb+1
1706 itype=-label
1707 IF(itype == 2) ncgbw=ncgbw+1
1708 END IF
1709 last=label
1710 IF(label > 0) THEN
1711 itgbi=inone(label) ! -> ITGBI= index of parameter label
1712 globalparcons(itgbi)=globalparcons(itgbi)+1
1713 END IF
1714 IF(label > 0.AND.itype == 2) THEN ! weighted constraints
1715 itgbi=inone(label) ! -> ITGBI= index of parameter label
1717 END IF
1718 END DO
1719
1720 WRITE(*,*)
1721 IF (ncgbw == 0) THEN
1722 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files'
1723 ELSE
1724 WRITE(*,*) 'GRPCON:',ncgb,' constraints found in steering files,',ncgbw, 'weighted'
1725 END IF
1726 WRITE(*,*)
1727
1728 ! keys and index for sorting of constraints
1729 length=ncgb+1; rows=3
1730 CALL mpalloc(matconssort,rows,length,'keys and index for sorting (I)')
1731 matconssort(1,ncgb+1)=ntgb+1
1732 ! start of constraint in list
1733 CALL mpalloc(vecconsstart,length,'start of constraint in list (I)')
1735 ! start and parameter range of constraint groups
1736 CALL mpalloc(matconsgroups,rows,length,'start of constraint groups, par. range (I)')
1737 ! parameter ranges (all, variable) of constraints
1738 length=ncgb; rows=4
1739 CALL mpalloc(matconsranges,rows,length,'parameter ranges for constraint (I)')
1740
1741 length=ncgb; rows=3
1742 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
1743 matconsgroupindex=0
1744 length=ncgb+1
1745 CALL mpalloc(vecconsparoffsets,length,'offsets for global par list for cons. (I)')
1746 length=ntgb+1
1747 CALL mpalloc(vecparconsoffsets,length,'offsets for cons. list for global par. (I)')
1748 vecparconsoffsets(1)=0
1749 DO i=1,ntgb
1750 vecparconsoffsets(i+1)=vecparconsoffsets(i)+globalparcons(i)
1751 END DO
1753
1754 length=vecparconsoffsets(ntgb+1)
1755 CALL mpalloc(vecconsparlist,length,'global par. list for constraint (I)')
1756 CALL mpalloc(vecparconslist,length,'constraint list for global par. (I)')
1757
1758 ! prepare
1759 i=1
1760 ioff=0
1761 vecconsparoffsets(1)=ioff
1762 DO icgb=1,ncgb
1763 ! new constraint
1764 vecconsstart(icgb)=i
1765 line1=-listconstraints(i)%label
1766 npar=0
1767 i=i+2
1768 DO
1769 label=listconstraints(i)%label
1770 itgbi=inone(label) ! -> ITGBI= index of parameter label
1771 ! list of constraints for 'itgbi'
1772 globalparcons(itgbi)=globalparcons(itgbi)+1
1773 vecparconslist(vecparconsoffsets(itgbi)+globalparcons(itgbi))=icgb
1774 npar=npar+1
1775 vecconsparlist(ioff+npar)=itgbi
1776 i=i+1
1777 IF(i > lenconstraints) EXIT
1778 IF(listconstraints(i)%label < 0) EXIT
1779 END DO
1780 ! sort to find duplicates
1781 CALL sort1k(vecconsparlist(ioff+1),npar)
1782 last=-1
1783 ndiff=0
1784 DO j=1,npar
1785 next=vecconsparlist(ioff+j)
1786 IF (next /= last) THEN
1787 ndiff=ndiff+1
1788 vecconsparlist(ioff+ndiff) = next
1789 END IF
1790 last=next
1791 END DO
1792 matconsranges(1,icgb)=vecconsparlist(ioff+1) ! min parameter
1793 matconsranges(3,icgb)=vecconsparlist(ioff+1) ! min parameter
1794 ioff=ioff+ndiff
1795 matconsranges(2,icgb)=vecconsparlist(ioff) ! max parameter
1796 matconsranges(4,icgb)=vecconsparlist(ioff) ! max parameter
1797 vecconsparoffsets(icgb+1)=ioff
1798 END DO
1800
1801 ! sort (by first, last parameter)
1802 DO icgb=1,ncgb
1803 matconssort(1,icgb)=matconsranges(1,icgb) ! first par.
1804 matconssort(2,icgb)=matconsranges(2,icgb) ! last par.
1805 matconssort(3,icgb)=icgb ! index
1806 END DO
1807 CALL sort2i(matconssort,ncgb)
1808
1809 IF (icheck>1) THEN
1810 print *, ' Constraint #parameters first par. last par. first line'
1811 END IF
1812 ! split into disjoint groups
1813 ncgrp=0
1815 DO jcgb=1,ncgb
1816 icgb=matconssort(3,jcgb)
1817 IF (icheck>0) THEN
1818 npar=vecconsparoffsets(icgb+1)-vecconsparoffsets(icgb)
1819 line1=-listconstraints(vecconsstart(icgb))%label
1820 labelf=globalparlabelindex(1,matconsranges(1,icgb))
1821 labell=globalparlabelindex(1,matconsranges(2,icgb))
1822 print *, jcgb, npar, labelf, labell, line1
1823 END IF
1824 ! already part of group?
1825 icgrp=matconsgroupindex(1,icgb)
1826 IF (icgrp == 0) THEN
1827 ! check all parameters
1828 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1829 itgbi=vecconsparlist(i)
1830 ! check all related constraints
1831 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1832 icgrp=matconsgroupindex(1,vecparconslist(j))
1833 ! already part of group?
1834 IF (icgrp > 0) EXIT
1835 END DO
1836 IF (icgrp > 0) EXIT
1837 END DO
1838 IF (icgrp == 0) THEN
1839 ! new group
1840 ncgrp=ncgrp+1
1841 icgrp=ncgrp
1842 END IF
1843 END IF
1844 ! add to group
1845 matconsgroupindex(2,icgb)=jcgb
1846 matconsgroupindex(3,icgb)=icgb
1847 DO i=vecconsparoffsets(icgb)+1, vecconsparoffsets(icgb+1)
1848 itgbi=vecconsparlist(i)
1849 globalparcons(itgbi)=icgrp
1850 ! mark all related constraints
1851 DO j=vecparconsoffsets(itgbi)+1,vecparconsoffsets(itgbi+1)
1852 matconsgroupindex(1,vecparconslist(j))=icgrp
1853 END DO
1854 END DO
1855 END DO
1856 WRITE(*,*) 'GRPCON:',ncgrp,' disjoint constraints groups built'
1857
1858 ! sort by group number
1859 CALL sort2i(matconsgroupindex,ncgb)
1860
1861 matconsgroups(1,1:ncgrp)=0
1862 DO jcgb=1,ncgb
1863 ! set up matConsSort
1864 icgb=matconsgroupindex(3,jcgb)
1865 matconssort(1,jcgb)=matconsranges(1,icgb)
1866 matconssort(2,jcgb)=matconsranges(2,icgb)
1867 matconssort(3,jcgb)=icgb
1868 ! set up matConsGroups
1869 icgrp=matconsgroupindex(1,jcgb)
1870 IF (matconsgroups(1,icgrp) == 0) THEN
1871 matconsgroups(1,icgrp)=jcgb
1872 matconsgroups(2,icgrp)=matconsranges(1,icgb)
1873 matconsgroups(3,icgrp)=matconsranges(2,icgb)
1874 ELSE
1875 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
1876 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
1877 END IF
1878 END DO
1879 matconsgroups(1,ncgrp+1)=ncgb+1
1880 matconsgroups(2,ncgrp+1)=ntgb+1
1881
1882 ! check for redundancy constraint groups
1883 ncgbr=0
1884 ncgrpr=0
1885 ncgbd=0
1886 ncgrpd=0
1887 IF (icheck>0) THEN
1888 print *
1889 print *, ' cons.group first con. first par. last par. #cons #par'
1890 ENDIF
1891 DO icgrp=1,ncgrp
1892 npar=0
1893 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1894 IF (globalparcons(i) == icgrp) npar=npar+1
1895 END DO
1896 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
1897 IF (icheck>0) THEN
1898 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1899 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1900 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ncon, npar
1901 END IF
1902 ! redundancy constraints?
1903 IF (ncon == npar) THEN
1904 IF (irslvrc > 0) THEN
1905 ncgrpr=ncgrpr+1
1906 ncgbr=ncgbr+ncon
1907 IF (icheck > 0) THEN
1908 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1909 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1910 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group resolved'
1911 END IF
1912 ! flag redundant parameters
1913 DO i=matconsgroups(2,icgrp),matconsgroups(3,icgrp)
1914 IF (globalparcons(i) == icgrp) globalparcons(i)=-icgrp
1915 END DO
1916 ! flag constraint group
1917 matconsgroups(2,icgrp)=ntgb+1
1918 matconsgroups(3,icgrp)=ntgb
1919 ELSE
1920 ncgrpd=ncgrpd+1
1921 ncgbd=ncgbd+ncon
1922 IF (icheck > 0) THEN
1923 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
1924 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
1925 print *, icgrp, matconsgroups(1,icgrp), labelf, labell, ' : cons.group redundant'
1926 END IF
1927 END IF
1928 END IF
1929 END DO
1930 IF (ncgrpr > 0) THEN
1931 WRITE(*,*) 'GRPCON:',ncgbr,' redundancy constraints in ', ncgrpr, ' groups resolved'
1932 ! all constraint groups resolved ?
1933 IF (ncgrpr == ncgrp) ncgrp=0
1934 ENDIF
1935 IF (ncgrpd > 0) THEN
1936 WRITE(*,*) 'GRPCON:',ncgbd,' redundancy constraints in ', ncgrpd, ' groups detected'
1937 ENDIF
1938 WRITE(*,*)
1939
1940 ! clean up
1941 CALL mpdealloc(vecparconslist)
1942 CALL mpdealloc(vecconsparlist)
1943 CALL mpdealloc(vecparconsoffsets)
1944 CALL mpdealloc(vecconsparoffsets)
1945 CALL mpdealloc(matconsgroupindex)
1946
1947END SUBROUTINE grpcon
1948
1952
1953SUBROUTINE prpcon
1954 USE mpmod
1955 USE mpdalc
1956
1957 IMPLICIT NONE
1958 INTEGER(mpi) :: i
1959 INTEGER(mpi) :: icgb
1960 INTEGER(mpi) :: icgrp
1961 INTEGER(mpi) :: ifrst
1962 INTEGER(mpi) :: ilast
1963 INTEGER(mpi) :: isblck
1964 INTEGER(mpi) :: itgbi
1965 INTEGER(mpi) :: ivgb
1966 INTEGER(mpi) :: j
1967 INTEGER(mpi) :: jcgb
1968 INTEGER(mpi) :: jfrst
1969 INTEGER(mpi) :: label
1970 INTEGER(mpi) :: labelf
1971 INTEGER(mpi) :: labell
1972 INTEGER(mpi) :: ncon
1973 INTEGER(mpi) :: ngrp
1974 INTEGER(mpi) :: npar
1975 INTEGER(mpi) :: ncnmxb
1976 INTEGER(mpi) :: ncnmxg
1977 INTEGER(mpi) :: nprmxb
1978 INTEGER(mpi) :: nprmxg
1979 INTEGER(mpi) :: inone
1980 INTEGER(mpi) :: nvar
1981
1982 INTEGER(mpl):: length
1983 INTEGER(mpl) :: rows
1984
1985 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: matConsGroupIndex
1986
1987 ncgbe=0
1988 !
1989 ! constraint groups already built in GRPCON based on steering,
1990 ! now care about fixed parameters
1991 !
1992 IF(ncgrp == 0) THEN ! no constraints groups
1993 ncgb=0
1994 ncblck=0
1995 RETURN
1996 END IF
1997
1998 length=ncgrp+1; rows=3
1999 ! start and parameter range of constraint blocks
2000 CALL mpalloc(matconsblocks,rows,length,'start of constraint blocks, par. range (I)')
2001
2002 length=ncgb; rows=3
2003 CALL mpalloc(matconsgroupindex,rows,length,'group index for constraint (I)')
2004 matconsgroupindex=0
2005
2006 ! check for empty constraints, redefine (accepted/active) constraints and groups
2007 ngrp=0
2008 ncgb=0
2009 DO icgrp=1,ncgrp
2010 ncon=ncgb
2011 ! resolved group ?
2012 IF (matconsgroups(2,icgrp) > matconsgroups(3,icgrp)) cycle
2013 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2014 icgb=matconssort(3,jcgb)
2015 i=vecconsstart(icgb)+2
2016 npar=0
2017 nvar=0
2018 matconsranges(1,icgb)=ntgb
2019 matconsranges(2,icgb)=1
2020 DO
2021 label=listconstraints(i)%label
2022 itgbi=inone(label) ! -> ITGBI= index of parameter label
2023 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2024 npar=npar+1
2025 IF(ivgb > 0) THEN
2026 nvar=nvar+1
2027 matconsranges(1,icgb)=min(matconsranges(1,icgb),itgbi)
2028 matconsranges(2,icgb)=max(matconsranges(2,icgb),itgbi)
2029 ENDIF
2030 i=i+1
2031 IF(i > lenconstraints) EXIT
2032 IF(listconstraints(i)%label < 0) EXIT
2033 END DO
2034 IF (nvar == 0) THEN
2035 ncgbe=ncgbe+1
2036 ! reset range
2037 matconsranges(1,icgb)=matconsranges(3,icgb)
2038 matconsranges(2,icgb)=matconsranges(4,icgb)
2039 END IF
2040 IF (nvar > 0 .OR. iskpec == 0) THEN
2041 ! constraint accepted (or kept)
2042 ncgb=ncgb+1
2043 matconsgroupindex(1,ncgb)=ngrp+1
2044 matconsgroupindex(2,ncgb)=icgb
2045 matconsgroupindex(3,ncgb)=nvar
2046 END IF
2047 END DO
2048 IF (ncgb > ncon) ngrp=ngrp+1
2049 END DO
2050 ncgrp=ngrp
2051
2052 IF (ncgbe > 0) THEN
2053 IF (iskpec > 0) THEN
2054 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints skipped'
2055 ELSE
2056 WRITE(*,*) 'PRPCON:',ncgbe,' empty constraints detected, to be fixed !!!'
2057 WRITE(*,*) ' (use option "skipemptycons" to skip those)'
2058 IF (icheck == 0) THEN
2059 icheck=2 ! switch to '-C'
2060 ncgbe=-ncgbe ! indicate that
2061 WRITE(*,*)
2062 WRITE(*,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2063 WRITE(8,*) '!!! Switch to "-C" (checking input only), no calculation of a solution !!!'
2064 WRITE(*,*)
2065 END IF
2066 END IF
2067 END IF
2068 WRITE(*,*) 'PRPCON:',ncgb,' constraints accepted'
2069 WRITE(*,*)
2070
2071 IF(ncgb == 0) RETURN ! no constraints left
2072
2073 ! already sorted by group number
2074
2075 matconsgroups(1,1:ncgrp)=0
2076 DO jcgb=1,ncgb
2077 ! set up matConsSort
2078 icgb=matconsgroupindex(2,jcgb)
2079 matconssort(1,jcgb)=matconsranges(1,icgb)
2080 matconssort(2,jcgb)=matconsranges(2,icgb)
2081 matconssort(3,jcgb)=icgb
2082 ! set up matConsGroups
2083 icgrp=matconsgroupindex(1,jcgb)
2084 IF (matconsgroups(1,icgrp) == 0) THEN
2085 matconsgroups(1,icgrp)=jcgb
2086 matconsgroups(2,icgrp)=matconsranges(1,icgb)
2087 matconsgroups(3,icgrp)=matconsranges(2,icgb)
2088 ELSE
2089 matconsgroups(2,icgrp)=min(matconsgroups(2,icgrp),matconsranges(1,icgb))
2090 matconsgroups(3,icgrp)=max(matconsgroups(3,icgrp),matconsranges(2,icgb))
2091 END IF
2092 END DO
2093 matconsgroups(1,ncgrp+1)=ncgb+1
2094 matconsgroups(2,ncgrp+1)=ntgb+1
2095
2096 ! loop over constraints groups, combine into non overlapping blocks
2097 ncblck=0
2098 ncnmxg=0
2099 nprmxg=0
2100 ncnmxb=0
2101 nprmxb=0
2102 mszcon=0
2103 mszprd=0
2104 isblck=1
2105 ilast=0
2106 IF (icheck > 0) THEN
2107 WRITE(*,*)
2108 IF (icheck > 1) &
2109 WRITE(*,*) ' Cons. sorted index #var.par. first line first label last label'
2110 WRITE(*,*) ' Cons. group index first cons. last cons. first label last label'
2111 WRITE(*,*) ' Cons. block index first group last group first label last label'
2112 END IF
2113 DO icgrp=1,ncgrp
2114 IF (icheck > 1) THEN
2115 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2116 icgb=matconssort(3,jcgb)
2117 nvar=matconsgroupindex(3,jcgb)
2118 labelf=globalparlabelindex(1,matconssort(1,jcgb))
2119 labell=globalparlabelindex(1,matconssort(2,jcgb))
2120 IF (nvar > 0) THEN
2121 WRITE(*,*) ' Cons. sorted', jcgb, nvar, &
2122 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2123 ELSE
2124 WRITE(*,*) ' Cons. sorted', jcgb, ' empty (0)', &
2125 -listconstraints(vecconsstart(icgb))%label, labelf, labell
2126 END IF
2127 END DO
2128 END IF
2129 IF (icheck > 0) THEN
2130 !ivgb=globalParLabelIndex(2,matConsGroups(2,icgrp)) ! -> index of variable global parameter
2131 labelf=globalparlabelindex(1,matconsgroups(2,icgrp))
2132 labell=globalparlabelindex(1,matconsgroups(3,icgrp))
2133 WRITE(*,*) ' Cons. group ', icgrp, matconsgroups(1,icgrp), &
2134 matconsgroups(1,icgrp+1)-1, labelf, labell
2135 ENDIF
2136 ! combine into non overlapping blocks
2137 ilast=max(ilast, matconsgroups(3,icgrp))
2138 IF (matconsgroups(2,icgrp+1) > ilast) THEN
2139 ncblck=ncblck+1
2140 ifrst=matconsgroups(2,isblck)
2142 matconsblocks(2,ncblck)=ifrst ! save first parameter in block
2143 matconsblocks(3,ncblck)=ilast ! save last parameter in block
2144 ! update matConsSort
2145 jfrst=matconsgroups(2,icgrp)
2146 DO i=icgrp,isblck,-1
2147 DO j=matconsgroups(1,i),matconsgroups(1,i+1)-1
2148 ! non zero range (from group)
2149 matconsranges(1,j)=matconsgroups(2,i)
2151 ! storage range (from max group, ilast)
2152 jfrst=min(jfrst,matconsgroups(2,i))
2153 matconsranges(3,j)=jfrst
2154 matconsranges(4,j)=ilast
2155 END DO
2156 END DO
2157 IF (icheck > 0) THEN
2158 labelf=globalparlabelindex(1,ifrst)
2159 labell=globalparlabelindex(1,ilast)
2160 WRITE(*,*) ' Cons. block ', ncblck, isblck, icgrp, labelf, labell
2161 ENDIF
2162 ! reset for new block
2163 isblck=icgrp+1
2164 END IF
2165 END DO
2167
2168 ! convert from total parameter index to index of variable global parameter
2169 DO i=1,ncblck
2170 ifrst=globalparlabelindex(2,matconsblocks(2,i)) ! -> index of variable global parameter
2171 ilast=globalparlabelindex(2,matconsblocks(3,i)) ! -> index of variable global parameter
2172 IF (ifrst > 0) THEN
2173 matconsblocks(2,i)=ifrst
2174 matconsblocks(3,i)=ilast
2175 ! statistics
2176 ncon=matconsblocks(1,i+1)-matconsblocks(1,i)
2177 npar=ilast+1-ifrst
2178 ncnmxb=max(ncnmxb,ncon)
2179 nprmxb=max(nprmxb,npar)
2180 ! update index ranges
2181 globalindexranges(ifrst)=max(globalindexranges(ifrst),ilast)
2182 ELSE
2183 ! empty
2184 matconsblocks(2,i)=1
2185 matconsblocks(3,i)=0
2186 END IF
2187 END DO
2188 DO icgrp=1,ncgrp
2189 ifrst=globalparlabelindex(2,matconsgroups(2,icgrp)) ! -> index of variable global parameter
2190 ilast=globalparlabelindex(2,matconsgroups(3,icgrp)) ! -> index of variable global parameter
2191 IF (ifrst > 0) THEN
2192 matconsgroups(2,icgrp)=ifrst
2193 matconsgroups(3,icgrp)=ilast
2194 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2195 DO i=1,4
2196 ivgb=globalparlabelindex(2,matconsranges(i,jcgb)) ! -> index of variable global parameter
2197 matconsranges(i,jcgb)=ivgb
2198 END DO
2199 END DO
2200 ! storage sizes, statistics
2201 jcgb=matconsgroups(1,icgrp) ! first cons.
2202 ncon=matconsgroups(1,icgrp+1)-jcgb
2203 npar=matconsranges(4,jcgb)+1-matconsranges(3,jcgb)
2204 ncnmxg=max(ncnmxg,ncon)
2205 nprmxg=max(nprmxg,npar)
2206 mszcon=mszcon+int(ncon,mpl)*int(npar,mpl) ! (sum of) block size for constraint matrix
2207 mszprd=mszprd+int(ncon,mpl)*int(ncon+1,mpl)/2 ! (sum of) block size for product matrix
2208 ELSE
2209 ! empty
2210 matconsgroups(2,icgrp)=1
2211 matconsgroups(3,icgrp)=0
2212 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2213 matconsranges(1,jcgb)=1
2214 matconsranges(2,jcgb)=0
2215 matconsranges(3,jcgb)=1
2216 matconsranges(4,jcgb)=0
2217 END DO
2218 END IF
2219 END DO
2220
2221 ! clean up
2222 CALL mpdealloc(matconsgroupindex)
2223
2224 ! save constraint group for global parameters
2226 DO icgrp=1,ncgrp
2227 DO jcgb=matconsgroups(1,icgrp),matconsgroups(1,icgrp+1)-1
2228 ! index in list
2229 icgb=matconssort(3,jcgb)
2230 DO j=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
2231 label=listconstraints(j)%label
2232 itgbi=inone(label) ! -> ITGBI= index of parameter label
2233 globalparcons(itgbi)=icgrp ! save constraint group
2234 END DO
2235 END DO
2236 END DO
2237
2238 IF (ncgrp+icheck > 1) THEN
2239 WRITE(*,*)
2240 WRITE(*,*) 'PRPCON: constraints split into ', ncgrp, '(disjoint) groups,'
2241 WRITE(*,*) ' groups combined into ', ncblck, '(non overlapping) blocks'
2242 WRITE(*,*) ' max group size (cons., par.) ', ncnmxg, nprmxg
2243 WRITE(*,*) ' max block size (cons., par.) ', ncnmxb, nprmxb
2244 IF (icheck > 0) WRITE(*,*) ' total block matrix sizes ', mszcon, mszprd
2245 END IF
2246
2247END SUBROUTINE prpcon
2248
2252
2253SUBROUTINE feasma
2254 USE mpmod
2255 USE mpdalc
2256
2257 IMPLICIT NONE
2258 REAL(mpd) :: factr
2259 REAL(mpd) :: sgm
2260 INTEGER(mpi) :: i
2261 INTEGER(mpi) :: icgb
2262 INTEGER(mpi) :: icgrp
2263 INTEGER(mpl) :: ij
2264 INTEGER(mpi) :: ifirst
2265 INTEGER(mpi) :: ilast
2266 INTEGER(mpl) :: ioffc
2267 INTEGER(mpl) :: ioffp
2268 INTEGER(mpi) :: irank
2269 INTEGER(mpi) :: ipar0
2270 INTEGER(mpi) :: itgbi
2271 INTEGER(mpi) :: ivgb
2272 INTEGER(mpi) :: j
2273 INTEGER(mpi) :: jcgb
2274 INTEGER(mpl) :: ll
2275 INTEGER(mpi) :: label
2276 INTEGER(mpi) :: ncon
2277 INTEGER(mpi) :: npar
2278 INTEGER(mpi) :: nrank
2279 INTEGER(mpi) :: inone
2280
2281 REAL(mpd):: rhs
2282 REAL(mpd):: evmax
2283 REAL(mpd):: evmin
2284 INTEGER(mpl):: length
2285 REAL(mpd), DIMENSION(:), ALLOCATABLE :: matConstraintsT
2286 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
2287 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
2288 SAVE
2289 ! ...
2290
2291 IF(ncgb == 0) RETURN ! no constraints
2292
2293 ! product matrix A A^T (A is stored as transposed)
2294 length=mszprd
2295 CALL mpalloc(matconsproduct, length, 'product matrix of constraints (blocks)')
2296 matconsproduct=0.0_mpd
2297 length=ncgb
2298 CALL mpalloc(vecconsresiduals, length, 'residuals of constraints')
2299 CALL mpalloc(vecconssolution, length, 'solution for constraints')
2300 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
2301 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
2302 ! constraint matrix A (A is stored as transposed)
2303 length = mszcon
2304 CALL mpalloc(matconstraintst,length,'transposed matrix of constraints (blocks)')
2305 matconstraintst=0.0_mpd
2306
2307 ! loop over sorted constraints, fill matrices, get rank, inverted product matrix (in groups)
2308 ioffc=0 ! group offset in constraint matrix
2309 ioffp=0 ! group offset in product matrix
2310 nrank=0
2311 DO icgrp=1,ncgrp
2312 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2313 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2314 ncon=ilast+1-ifirst
2315 ipar0=matconsranges(3,ifirst)-1 ! parameter offset
2316 npar=matconsranges(4,ifirst)-ipar0 ! number of parameters
2317 IF (npar <= 0) THEN
2318 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, 0, ' (empty)'
2319 cycle ! skip empty groups/cons.
2320 END IF
2321 DO jcgb=ifirst,ilast
2322 ! index in list
2323 icgb=matconssort(3,jcgb)
2324 ! fill constraint matrix
2325 i=vecconsstart(icgb)
2326 rhs=listconstraints(i )%value ! right hand side
2327 sgm=listconstraints(i+1)%value ! sigma parameter
2328 DO j=i+2,vecconsstart(icgb+1)-1
2329 label=listconstraints(j)%label
2330 factr=listconstraints(j)%value
2331 itgbi=inone(label) ! -> ITGBI= index of parameter label
2332 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2333 IF(ivgb > 0) matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)= &
2334 matconstraintst(int(jcgb-ifirst,mpl)*int(npar,mpl)+ivgb-ipar0+ioffc)+factr ! matrix element
2335 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2336 END DO
2337 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2338 END DO
2339
2340 ! get rank of groups
2341 DO ll=ioffc+1,ioffc+npar
2342 ij=ioffp
2343 DO i=1,ncon
2344 DO j=1,i
2345 ij=ij+1
2346 matconsproduct(ij)=matconsproduct(ij)+ &
2347 matconstraintst(int(i-1,mpl)*int(npar,mpl)+ll)* &
2348 matconstraintst(int(j-1,mpl)*int(npar,mpl)+ll)
2349 END DO
2350 END DO
2351 END DO
2352 ! inversion of product matrix of constraints
2353 CALL sqminv(matconsproduct(ioffp+1:ij),vecconsresiduals(ifirst:ilast),ncon,irank, auxvectord, auxvectori)
2354 IF (icheck > 1 .OR. irank < ncon) THEN
2355 WRITE(*,*) ' Constraint group, #con, rank', icgrp, ncon, irank
2356 IF (irank < ncon) THEN
2357 WRITE(*,*) ' .. rank deficit !! '
2358 WRITE(*,*) ' E.g. fix all parameters and remove all constraints related to label ', &
2360 END IF
2361 END IF
2362 nrank=nrank+irank
2363 ioffc=ioffc+int(npar,mpl)*int(ncon,mpl)
2364 ioffp=ij
2365 END DO
2366
2367 nmiss1=ncgb-nrank
2368
2369 WRITE(*,*) ' '
2370 WRITE(*,*) 'Rank of product matrix of constraints is',nrank, &
2371 ' for',ncgb,' constraint equations'
2372 WRITE(8,*) 'Rank of product matrix of constraints is',nrank, &
2373 ' for',ncgb,' constraint equations'
2374 IF(nrank < ncgb) THEN
2375 WRITE(*,*) 'Warning: insufficient constraint equations!'
2376 WRITE(8,*) 'Warning: insufficient constraint equations!'
2377 IF (iforce == 0) THEN
2378 isubit=1
2379 WRITE(*,*) ' --> enforcing SUBITO mode'
2380 WRITE(8,*) ' --> enforcing SUBITO mode'
2381 END IF
2382 END IF
2383
2384 ! QL decomposition
2385 IF (nfgb < nvgb) THEN
2386 print *
2387 print *, 'QL decomposition of constraints matrix'
2388 ! monitor progress
2389 IF(monpg1 > 0) THEN
2390 WRITE(lunlog,*) 'QL decomposition of constraints matrix'
2392 END IF
2393 IF(icelim < 2) THEN ! True unless unpacked LAPACK
2394 ! QL decomposition
2396 ! loop over parameter blocks
2398 ! check eignevalues of L
2399 CALL qlgete(evmin,evmax)
2400#ifdef LAPACK64
2401 ELSE
2402 CALL lpqldec(matconstraintst,evmin,evmax)
2403#endif
2404 END IF
2405 IF(monpg1 > 0) CALL monend()
2406 print *, ' largest |eigenvalue| of L: ', evmax
2407 print *, ' smallest |eigenvalue| of L: ', evmin
2408 IF (evmin == 0.0_mpd.AND.icheck == 0) THEN
2409 CALL peend(27,'Aborted, singular QL decomposition of constraints matrix')
2410 stop 'FEASMA: stopping due to singular QL decomposition of constraints matrix'
2411 END IF
2412 END IF
2413
2414 CALL mpdealloc(matconstraintst)
2415 CALL mpdealloc(auxvectord)
2416 CALL mpdealloc(auxvectori)
2417
2418 RETURN
2419END SUBROUTINE feasma ! matrix for feasible solution
2420
2428SUBROUTINE feasib(concut,iact)
2429 USE mpmod
2430 USE mpdalc
2431
2432 IMPLICIT NONE
2433 REAL(mpd) :: factr
2434 REAL(mpd) :: sgm
2435 INTEGER(mpi) :: i
2436 INTEGER(mpi) :: icgb
2437 INTEGER(mpi) :: icgrp
2438 INTEGER(mpi) :: iter
2439 INTEGER(mpi) :: itgbi
2440 INTEGER(mpi) :: ivgb
2441 INTEGER(mpi) :: ieblck
2442 INTEGER(mpi) :: isblck
2443 INTEGER(mpi) :: ifirst
2444 INTEGER(mpi) :: ilast
2445 INTEGER(mpi) :: j
2446 INTEGER(mpi) :: jcgb
2447 INTEGER(mpi) :: label
2448 INTEGER(mpi) :: inone
2449 INTEGER(mpi) :: ncon
2450
2451 REAL(mps), INTENT(IN) :: concut
2452 INTEGER(mpi), INTENT(OUT) :: iact
2453
2454 REAL(mpd) :: rhs
2455 REAL(mpd) ::sum1
2456 REAL(mpd) ::sum2
2457 REAL(mpd) ::sum3
2458
2459 REAL(mpd), DIMENSION(:), ALLOCATABLE :: vecCorrections
2460 SAVE
2461
2462 iact=0
2463 IF(ncgb == 0) RETURN ! no constraints
2464
2465 DO iter=1,2
2466 vecconsresiduals=0.0_mpd
2467
2468 ! calculate right constraint equation discrepancies
2469 DO jcgb=1,ncgb
2470 icgb=matconssort(3,jcgb) ! unsorted constraint index
2471 i=vecconsstart(icgb)
2472 rhs=listconstraints(i )%value ! right hand side
2473 sgm=listconstraints(i+1)%value ! sigma parameter
2474 DO j=i+2,vecconsstart(icgb+1)-1
2475 label=listconstraints(j)%label
2476 factr=listconstraints(j)%value
2477 itgbi=inone(label) ! -> ITGBI= index of parameter label
2478 rhs=rhs-factr*globalparameter(itgbi) ! reduce residuum
2479 ENDDO
2480 vecconsresiduals(jcgb)=rhs ! constraint discrepancy
2481 END DO
2482
2483 ! constraint equation discrepancies -------------------------------
2484
2485 sum1=0.0_mpd
2486 sum2=0.0_mpd
2487 sum3=0.0_mpd
2488 DO icgb=1,ncgb
2489 sum1=sum1+vecconsresiduals(icgb)**2
2490 sum2=sum2+abs(vecconsresiduals(icgb))
2491 sum3=max(sum3,abs(vecconsresiduals(icgb)))
2492 END DO
2493 sum1=sqrt(sum1/real(ncgb,mpd))
2494 sum2=sum2/real(ncgb,mpd)
2495
2496 IF(iter == 1.AND.sum1 < concut) RETURN ! do nothing if correction small
2497
2498 IF(iter == 1.AND.ncgb <= 12) THEN
2499 WRITE(*,*) ' '
2500 WRITE(*,*) 'Constraint equation discrepancies:'
2501 WRITE(*,101) (icgb,vecconsresiduals(icgb),icgb=1,ncgb)
2502101 FORMAT(4x,4(i5,g12.4))
2503 WRITE(*,103) concut
2504103 FORMAT(10x,' Cut on rms value is',g8.1)
2505 END IF
2506
2507 IF(iact == 0) THEN
2508 WRITE(*,*) ' '
2509 WRITE(*,*) 'Improve constraints'
2510 END IF
2511 iact=1
2512
2513 WRITE(*,102) iter,sum1,sum2,sum3
2514102 FORMAT(i6,' rms',g12.4,' avrg_abs',g12.4,' max_abs',g12.4)
2515
2516 CALL mpalloc(veccorrections,int(nvgb,mpl),'constraint corrections')
2517 veccorrections=0.0_mpd
2518
2519 ! multiply (group-wise) inverse matrix and constraint vector
2520 isblck=0
2521 DO icgrp=1,ncgrp
2522 ifirst=matconsgroups(1,icgrp) ! first constraint in group
2523 ilast=matconsgroups(1,icgrp+1)-1 ! last constraint in group
2524 ncon=ilast+1-ifirst
2525 ieblck=isblck+(ncon*(ncon+1))/2
2526 CALL dbsvx(matconsproduct(isblck+1:ieblck),vecconsresiduals(ifirst:ilast),vecconssolution(ifirst:ilast),ncon)
2527 isblck=ieblck
2528 END DO
2529
2530 DO jcgb=1,ncgb
2531 icgb=matconssort(3,jcgb) ! unsorted constraint index
2532 i=vecconsstart(icgb)
2533 rhs=listconstraints(i )%value ! right hand side
2534 sgm=listconstraints(i+1)%value ! sigma parameter
2535 DO j=i+2,vecconsstart(icgb+1)-1
2536 label=listconstraints(j)%label
2537 factr=listconstraints(j)%value
2538 itgbi=inone(label) ! -> ITGBI= index of parameter label
2539 ivgb =globalparlabelindex(2,itgbi) ! -> index of variable global parameter
2540 IF(ivgb > 0) THEN
2541 veccorrections(ivgb)=veccorrections(ivgb)+vecconssolution(jcgb)*factr
2542 END IF
2543 ENDDO
2544 END DO
2545
2546 DO i=1,nvgb ! add corrections
2547 itgbi=globalparvartototal(i)
2548 globalparameter(itgbi)=globalparameter(itgbi)+veccorrections(i)
2549 END DO
2550
2551 CALL mpdealloc(veccorrections)
2552
2553 END DO ! iteration 1 and 2
2554
2555END SUBROUTINE feasib ! make parameters feasible
2556
2589SUBROUTINE peread(more)
2590 USE mpmod
2591
2592 IMPLICIT NONE
2593 INTEGER(mpi) :: i
2594 INTEGER(mpi) :: iact
2595 INTEGER(mpi) :: ierrc
2596 INTEGER(mpi) :: ierrf
2597 INTEGER(mpi) :: ioffp
2598 INTEGER(mpi) :: ios
2599 INTEGER(mpi) :: ithr
2600 INTEGER(mpi) :: jfile
2601 INTEGER(mpi) :: jrec
2602 INTEGER(mpi) :: k
2603 INTEGER(mpi) :: kfile
2604 INTEGER(mpi) :: l
2605 INTEGER(mpi) :: lun
2606 INTEGER(mpi) :: mpri
2607 INTEGER(mpi) :: n
2608 INTEGER(mpi) :: nact
2609 INTEGER(mpi) :: nbuf
2610 INTEGER(mpi) :: ndata
2611 INTEGER(mpi) :: noff
2612 INTEGER(mpi) :: noffs
2613 INTEGER(mpi) :: npointer
2614 INTEGER(mpi) :: npri
2615 INTEGER(mpi) :: nr
2616 INTEGER(mpi) :: nrc
2617 INTEGER(mpi) :: nrd
2618 INTEGER(mpi) :: nrpr
2619 INTEGER(mpi) :: nthr
2620 INTEGER(mpi) :: ntot
2621 INTEGER(mpi) :: maxRecordSize
2622 INTEGER(mpi) :: maxRecordFile
2623
2624 INTEGER(mpi), INTENT(OUT) :: more
2625
2626 LOGICAL :: lprint
2627 LOGICAL :: floop
2628 LOGICAL :: eof
2629 REAL(mpd) :: ds0
2630 REAL(mpd) :: ds1
2631 REAL(mpd) :: ds2
2632 REAL(mpd) :: dw
2633 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
2634 CHARACTER (LEN=7) :: cfile
2635 SAVE
2636
2637#ifdef READ_C_FILES
2638 INTERFACE
2639 SUBROUTINE readc(bufferD, bufferF, bufferI, bufferLength, lun, err) BIND(c)
2640 USE iso_c_binding
2641 REAL(c_double), DIMENSION(*), INTENT(OUT) :: bufferD
2642 REAL(c_float), DIMENSION(*), INTENT(OUT) :: bufferF
2643 INTEGER(c_int), DIMENSION(*), INTENT(OUT) :: bufferI
2644 INTEGER(c_int), INTENT(INOUT) :: bufferLength
2645 INTEGER(c_int), INTENT(IN), VALUE :: lun
2646 INTEGER(c_int), INTENT(OUT) :: err
2647 END SUBROUTINE readc
2648 END INTERFACE
2649#endif
2650
2651 DATA lprint/.true./
2652 DATA floop/.true./
2653 DATA npri / 0 /, mpri / 1000 /
2654 ! ...
2655 IF(ifile == 0) THEN ! start/restart
2656 nrec=0
2657 nrecd=0
2658 ntot=0
2659 sumrecords=0
2661 numblocks=0
2664 readbufferinfo=0 ! reset management info
2665 nrpr=1
2666 nthr=mthrdr
2667 nact=0 ! active threads (have something still to read)
2668 DO k=1,nthr
2669 IF (ifile < nfilb) THEN
2670 ifile=ifile+1
2672 readbufferinfo(2,k)=nact
2673 nact=nact+1
2674 END IF
2675 END DO
2676 END IF
2677 npointer=size(readbufferpointer)/nact
2678 ndata=size(readbufferdatai)/nact
2679 more=-1
2680 DO k=1,nthr
2681 iact=readbufferinfo(2,k)
2682 readbufferinfo(4,k)=0 ! reset counter
2683 readbufferinfo(5,k)=iact*ndata ! reset offset
2684 END DO
2685 numblocks=numblocks+1 ! new block
2686
2687 !$OMP PARALLEL &
2688 !$OMP DEFAULT(PRIVATE) &
2689 !$OMP SHARED(readBufferInfo,readBufferPointer,readBufferDataI,readBufferDataD, &
2690 !$OMP readBufferDataF,nPointer,nData,skippedRecords,ndimbuf,NTHR,NFILF,FLOOP, &
2691 !$OMP IFD,KFD,IFILE,NFILB,WFD,XFD,icheck,keepOpen,ireeof,nrderr) NUM_THREADS(NTHR)
2692 ! NUM_THREADS(NTHR) moved to previuos line to make OPARI2 used by scorep-8.4. happy
2693 ithr=1
2694 !$ ITHR=OMP_GET_THREAD_NUM()+1 ! thread number
2695 jfile=readbufferinfo(1,ithr) ! file index
2696 iact =readbufferinfo(2,ithr) ! active thread number
2697 jrec =readbufferinfo(3,ithr) ! records read
2698 ioffp=iact*npointer
2699 noffs=(ithr-1)*ndimbuf ! offset for intermediate float buffer
2700
2701 files: DO WHILE (jfile > 0)
2702 kfile=kfd(2,jfile)
2703 ! open again
2704 IF (keepopen < 1 .AND. readbufferinfo(3,ithr) == 0) THEN
2705 CALL binopn(kfile,ithr,ios)
2706 END IF
2707 records: DO
2708 nbuf=readbufferinfo(4,ithr)+1
2709 noff=readbufferinfo(5,ithr)+2 ! 2 header words per record
2710 nr=ndimbuf
2711 IF(kfile <= nfilf) THEN ! Fortran file
2712 lun=kfile+10
2713 READ(lun,iostat=ierrf) n,(readbufferdataf(noffs+i),i=1,min(n/2,nr)),&
2714 (readbufferdatai(noff+i),i=1,min(n/2,nr))
2715 nr=n/2
2716 ! convert to double
2717 DO i=1,nr
2718 readbufferdatad(noff+i)=real(readbufferdataf(noffs+i),mpr8)
2719 END DO
2720 ! IF (ierrf < 0) REWIND lun ! end-of-file ! CHK use binrwd()
2721 eof=(ierrf /= 0)
2722 ELSE ! C file
2723 lun=kfile-nfilf
2724 IF (keepopen < 1) lun=ithr
2725#ifdef READ_C_FILES
2726 CALL readc(readbufferdatad(noff+1),readbufferdataf(noffs+1),readbufferdatai(noff+1),nr,lun,ierrc)
2727 n=nr+nr
2728 IF (ierrc > 4) readbufferinfo(6,ithr)=readbufferinfo(6,ithr)+1
2729#else
2730 ierrc=0
2731#endif
2732 eof=(ierrc <= 0.AND.ierrc /= -4) ! allow buffer overruns -> skip record
2733 IF(eof.AND.ierrc < 0) THEN
2734 WRITE(*,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2735 WRITE(8,*) 'Read error for binary Cfile', kfile, 'record', jrec+1, ':', ierrc
2736 IF (icheck <= 0 .AND. ireeof <=0) THEN ! stop unless 'checkinput' mode or 'readerroraseof'
2737 WRITE(cfile,'(I7)') kfile
2738 CALL peend(18,'Aborted, read error(s) for binary file ' // cfile)
2739 stop 'PEREAD: stopping due to read errors'
2740 END IF
2741 IF (kfd(1,jfile) == 1) THEN ! count files with read errors in first loop
2742 !$OMP ATOMIC
2743 nrderr=nrderr+1
2744 END IF
2745 END IF
2746 END IF
2747 IF(eof) EXIT records ! end-of-files or error
2748
2749 jrec=jrec+1
2750 readbufferinfo(3,ithr)=jrec
2751 IF(floop) THEN
2752 xfd(jfile)=max(xfd(jfile),n)
2753 IF(ithr == 1) THEN
2754 CALL hmplnt(1,n)
2755 IF(readbufferdatai(noff+1) /= 0) CALL hmpent(8,real(readbufferdatai(noff+1),mps))
2756 END IF
2757 END IF
2758
2759 IF (nr <= ndimbuf) THEN
2760 readbufferinfo(4,ithr)=nbuf
2761 readbufferinfo(5,ithr)=noff+nr
2762
2763 readbufferpointer(ioffp+nbuf)=noff ! pointer to start of buffer
2764 readbufferdatai(noff )=noff+nr ! pointer to end of buffer
2765 readbufferdatai(noff-1)=jrec ! local record number
2766 readbufferdatad(noff )=real(kfile,mpr8) ! file number
2767 readbufferdatad(noff-1)=real(wfd(kfile),mpr8) ! weight
2768
2769 IF ((noff+nr+2+ndimbuf >= ndata*(iact+1)).OR.(nbuf >= npointer)) EXIT files ! buffer full
2770 ELSE
2771 !$OMP ATOMIC
2773 cycle records
2774 END IF
2775
2776 END DO records
2777
2778 readbufferinfo(1,ithr)=-jfile ! flag eof
2779 IF (keepopen < 1) THEN ! close again
2780 CALL bincls(kfile,ithr)
2781 ELSE ! rewind
2782 CALL binrwd(kfile)
2783 END IF
2784 IF (kfd(1,jfile) == 1) THEN
2785 print *, 'PEREAD: file ', kfile, 'read the first time, found',jrec,' records'
2786 kfd(1,jfile)=-jrec
2787 ELSE
2788 !PRINT *, 'PEREAD: file ', kfile, 'records', jrec, -kfd(1,jfile)
2789 IF (-kfd(1,jfile) /= jrec) THEN
2790 WRITE(cfile,'(I7)') kfile
2791 CALL peend(19,'Aborted, binary file modified (length) ' // cfile)
2792 stop 'PEREAD: file modified (length)'
2793 END IF
2794 END IF
2795 ! take next file
2796 !$OMP CRITICAL
2797 IF (ifile < nfilb) THEN
2798 ifile=ifile+1
2799 jrec=0
2800 readbufferinfo(1,ithr)=ifile
2801 readbufferinfo(3,ithr)=jrec
2802 END IF
2803 !$OMP END CRITICAL
2804 jfile=readbufferinfo(1,ithr)
2805
2806 END DO files
2807 !$OMP END PARALLEL
2808 ! compress pointers
2809 nrd=readbufferinfo(4,1) ! buffers from 1 .thread
2810 DO k=2,nthr
2811 iact =readbufferinfo(2,k)
2812 ioffp=iact*npointer
2813 nbuf=readbufferinfo(4,k)
2814 DO l=1,nbuf
2815 readbufferpointer(nrd+l)=readbufferpointer(ioffp+l)
2816 END DO
2817 nrd=nrd+nbuf
2818 END DO
2819
2820 more=0
2821 DO k=1,nthr
2822 jfile=readbufferinfo(1,k)
2823 IF (jfile > 0) THEN ! no eof yet
2824 readbufferinfo(2,k)=more
2825 more=more+1
2826 ELSE
2827 ! no more files, thread retires
2828 readbufferinfo(1,k)=0
2829 readbufferinfo(2,k)=-1
2830 readbufferinfo(3,k)=0
2832 readbufferinfo(6,k)=0
2833 END IF
2834 END DO
2835 ! record limit ?
2836 IF (mxrec > 0.AND.(ntot+nrd) >= mxrec) THEN
2837 nrd=mxrec-ntot
2838 more=-1
2839 DO k=1,nthr
2840 jfile=readbufferinfo(1,k)
2841 IF (jfile > 0) THEN ! rewind or close files
2842 nrc=readbufferinfo(3,k)
2843 IF (kfd(1,jfile) == 1) kfd(1,jfile)=-nrc
2844 kfile=kfd(2,jfile)
2845 IF (keepopen < 1) THEN ! close again
2846 CALL bincls(kfile,k)
2847 ELSE ! rewind
2848 CALL binrwd(kfile)
2849 END IF
2850 END IF
2851 END DO
2852 END IF
2853
2854 ntot=ntot+nrd
2855 nrec=ntot
2856 numreadbuffer=nrd
2857
2861
2862 DO WHILE (nloopn == 0.AND.ntot >= nrpr)
2863 WRITE(*,*) ' Record ',nrpr
2864 IF (nrpr < 100000) THEN
2865 nrpr=nrpr*10
2866 ELSE
2867 nrpr=nrpr+100000
2868 END IF
2869 END DO
2870
2871 IF (ncache > 0.AND.nloopn <= 1.AND. npri < mpri.AND.mprint > 1) THEN
2872 npri=npri+1
2873 IF (npri == 1) WRITE(*,100)
2874 WRITE(*,101) nrec, nrd, more ,ifile
2875100 FORMAT(/' PeRead records active file' &
2876 /' total block threads number')
2877101 FORMAT(' PeRead',4i10)
2878 END IF
2879
2880 IF (more <= 0) THEN
2881 ifile=0
2882 IF (floop) THEN
2883 ! check for file weights
2884 ds0=0.0_mpd
2885 ds1=0.0_mpd
2886 ds2=0.0_mpd
2887 maxrecordsize=0
2888 maxrecordfile=0
2889 DO k=1,nfilb
2890 IF (xfd(k) > maxrecordsize) THEN
2891 maxrecordsize=xfd(k)
2892 maxrecordfile=k
2893 END IF
2894 dw=real(-kfd(1,k),mpd)
2895 IF (wfd(k) /= 1.0) nfilw=nfilw+1
2896 ds0=ds0+dw
2897 ds1=ds1+dw*real(wfd(k),mpd)
2898 ds2=ds2+dw*real(wfd(k)**2,mpd)
2899 END DO
2900 print *, 'PEREAD: file ', maxrecordfile, 'with max record size ', maxrecordsize
2901 IF (nfilw > 0.AND.ds0 > 0.0_mpd) THEN
2902 ds1=ds1/ds0
2903 ds2=ds2/ds0-ds1*ds1
2904 DO lun=6,lunlog,2
2905 WRITE(lun,177) nfilw,real(ds1,mps),real(ds2,mps)
2906177 FORMAT(/' !!!!!',i4,' weighted binary files', &
2907 /' !!!!! mean, variance of weights =',2g12.4)
2908 END DO
2909 END IF
2910 ! integrate record numbers
2911 DO k=2,nfilb
2912 ifd(k)=ifd(k-1)-kfd(1,k-1)
2913 END DO
2914 ! sort
2915 IF (nthr > 1) CALL sort2k(kfd,nfilb)
2916 IF (skippedrecords > 0) THEN
2917 print *, 'PEREAD skipped records: ', skippedrecords
2918 ndimbuf=maxrecordsize/2 ! adjust buffer size
2919 END IF
2920 END IF
2921 lprint=.false.
2922 floop=.false.
2923 IF (ncache > 0.AND.nloopn <= 1.AND.mprint > 0) &
2925179 FORMAT(/' Read cache usage (#blocks, #records, ', &
2926 'min,max records/block'/17x,i10,i12,2i10)
2927 END IF
2928 RETURN
2929
2930END SUBROUTINE peread
2931
2939SUBROUTINE peprep(mode)
2940 USE mpmod
2941
2942 IMPLICIT NONE
2943
2944 INTEGER(mpi), INTENT(IN) :: mode
2945
2946 INTEGER(mpi) :: ibuf
2947 INTEGER(mpi) :: ichunk
2948 INTEGER(mpi) :: ist
2949 INTEGER(mpi) :: itgbi
2950 INTEGER(mpi) :: j
2951 INTEGER(mpi) :: ja
2952 INTEGER(mpi) :: jb
2953 INTEGER(mpi) :: jsp
2954 INTEGER(mpi) :: nst
2955 INTEGER(mpi), PARAMETER :: maxbad = 100 ! max number of bad records with print out
2956 INTEGER(mpi) :: nbad
2957 INTEGER(mpi) :: nerr
2958 INTEGER(mpi) :: inone
2959
2960 IF (mode > 0) THEN
2961#ifdef __PGIC__
2962 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
2963 ichunk=256
2964#else
2965 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
2966#endif
2967 ! parallelize record loop
2968 !$OMP PARALLEL DO &
2969 !$OMP DEFAULT(PRIVATE) &
2970 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,ICHUNK,iscerr,dscerr) &
2971 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
2972 DO ibuf=1,numreadbuffer ! buffer for current record
2973 ist=readbufferpointer(ibuf)+1
2975 DO ! loop over measurements
2976 CALL isjajb(nst,ist,ja,jb,jsp)
2977 IF(jb == 0) EXIT
2978 DO j=1,ist-jb
2979 readbufferdatai(jb+j)=inone( readbufferdatai(jb+j) ) ! translate to index
2980 END DO
2981 ! scale error ?
2982 IF (iscerr > 0) THEN
2983 IF (jb < ist) THEN
2984 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(1) ! 'global' measurement
2985 ELSE
2986 readbufferdatad(jb) = readbufferdatad(jb) * dscerr(2) ! 'local' measurement
2987 END IF
2988 END IF
2989 END DO
2990 END DO
2991 !$OMP END PARALLEL DO
2992 END IF
2993
2994 !$POMP INST BEGIN(peprep)
2995#ifdef SCOREP_USER_ENABLE
2996 scorep_user_region_by_name_begin("UR_peprep", scorep_user_region_type_common)
2997#endif
2998 IF (mode <= 0) THEN
2999 nbad=0
3000 DO ibuf=1,numreadbuffer ! buffer for current record
3001 CALL pechk(ibuf,nerr)
3002 IF(nerr > 0) THEN
3003 nbad=nbad+1
3004 IF(nbad >= maxbad) EXIT
3005 ELSE
3006 ist=readbufferpointer(ibuf)+1
3008 DO ! loop over measurements
3009 CALL isjajb(nst,ist,ja,jb,jsp)
3010 IF(jb == 0) EXIT
3011 neqn=neqn+1
3012 IF(jb == ist) cycle
3013 negb=negb+1
3014 ndgb=ndgb+(ist-jb)
3015 DO j=1,ist-jb
3016 itgbi=inone( readbufferdatai(jb+j) ) ! generate index
3017 END DO
3018 END DO
3019 END IF
3020 END DO
3021 IF(nbad > 0) THEN
3022 CALL peend(20,'Aborted, bad binary records')
3023 stop 'PEREAD: stopping due to bad records'
3024 END IF
3025 END IF
3026#ifdef SCOREP_USER_ENABLE
3027 scorep_user_region_by_name_end("UR_peprep")
3028#endif
3029 !$POMP INST END(peprep)
3030
3031END SUBROUTINE peprep
3032
3040SUBROUTINE pechk(ibuf, nerr)
3041 USE mpmod
3042
3043 IMPLICIT NONE
3044 INTEGER(mpi) :: i
3045 INTEGER(mpi) :: is
3046 INTEGER(mpi) :: ist
3047 INTEGER(mpi) :: ioff
3048 INTEGER(mpi) :: ja
3049 INTEGER(mpi) :: jb
3050 INTEGER(mpi) :: jsp
3051 INTEGER(mpi) :: nan
3052 INTEGER(mpi) :: nst
3053
3054 INTEGER(mpi), INTENT(IN) :: ibuf
3055 INTEGER(mpi), INTENT(OUT) :: nerr
3056 SAVE
3057 ! ...
3058
3059 ist=readbufferpointer(ibuf)+1
3061 nerr=0
3062 is=ist
3063 jsp=0
3064 outer: DO WHILE(is < nst)
3065 ja=0
3066 jb=0
3067 inner1: DO
3068 is=is+1
3069 IF(is > nst) EXIT outer
3070 IF(readbufferdatai(is) == 0) EXIT inner1 ! found 1. marker
3071 END DO inner1
3072 ja=is
3073 inner2: DO
3074 is=is+1
3075 IF(is > nst) EXIT outer
3076 IF(readbufferdatai(is) == 0) EXIT inner2 ! found 2. marker
3077 END DO inner2
3078 jb=is
3079 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3080 ! special data
3081 jsp=jb ! pointer to special data
3082 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3083 cycle outer
3084 END IF
3085 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3086 is=is+1
3087 END DO
3088 END DO outer
3089 IF(is > nst) THEN
3090 ioff = readbufferpointer(ibuf)
3091 WRITE(*,100) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi)
3092100 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' is broken !!!')
3093 nerr=nerr+1
3094 ENDIF
3095 nan=0
3096 DO i=ist, nst
3097 IF(.NOT.(readbufferdatad(i) <= 0.0_mpr8).AND..NOT.(readbufferdatad(i) > 0.0_mpr8)) nan=nan+1
3098 END DO
3099 IF(nan > 0) THEN
3100 ioff = readbufferpointer(ibuf)
3101 WRITE(*,101) readbufferdatai(ioff-1), int(readbufferdatad(ioff),mpi), nan
3102101 FORMAT(' PEREAD: record ', i8,' in file ',i6, ' contains ', i6, ' NaNs !!!')
3103 nerr= nerr+2
3104 ENDIF
3105
3106END SUBROUTINE pechk
3107
3112SUBROUTINE pepgrp
3113 USE mpmod
3114 USE mpdalc
3115
3116 IMPLICIT NONE
3117
3118 INTEGER(mpi) :: ibuf
3119 INTEGER(mpi) :: ichunk
3120 INTEGER(mpi) :: iproc
3121 INTEGER(mpi) :: ioff
3122 INTEGER(mpi) :: ioffbi
3123 INTEGER(mpi) :: ist
3124 INTEGER(mpi) :: itgbi
3125 INTEGER(mpi) :: j
3126 INTEGER(mpi) :: ja
3127 INTEGER(mpi) :: jb
3128 INTEGER(mpi) :: jsp
3129 INTEGER(mpi) :: nalg
3130 INTEGER(mpi) :: neqna
3131 INTEGER(mpi) :: nnz
3132 INTEGER(mpi) :: nst
3133 INTEGER(mpi) :: nzero
3134 INTEGER(mpi) :: inone
3135 INTEGER(mpl) :: length
3136 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
3137
3138 CALL useone ! make (INONE) usable
3139 globalparheader(-2)=-1 ! set flag to inhibit further updates
3140 ! need back index
3141 IF (mcount > 0) THEN
3142 length=globalparheader(-1)*mthrd
3143 CALL mpalloc(backindexusage,length,'global variable-index array')
3145 END IF
3146 nzero=0
3147#ifdef __PGIC__
3148 ! to prevent "PGF90-F-0000-Internal compiler error. Could not locate uplevel instance for stblock"
3149 ichunk=256
3150#else
3151 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
3152#endif
3153 ! parallelize record loop
3154 !$OMP PARALLEL DO &
3155 !$OMP DEFAULT(PRIVATE) &
3156 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,readBufferDataD,backIndexUsage,globalParHeader,ICHUNK,MCOUNT) &
3157 !$OMP REDUCTION(+:NZERO) &
3158 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
3159 DO ibuf=1,numreadbuffer ! buffer for current record
3160 ist=readbufferpointer(ibuf)+1
3162 IF (mcount > 0) THEN
3163 ! count per record
3164 iproc=0
3165 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
3166 ioffbi=globalparheader(-1)*iproc
3167 nalg=0
3168 ioff=readbufferpointer(ibuf)
3169 DO ! loop over measurements
3170 CALL isjajb(nst,ist,ja,jb,jsp)
3171 IF(jb == 0) EXIT
3172 IF (ist > jb) THEN
3173 DO j=1,ist-jb
3174 IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
3175 nzero=nzero+1
3176 cycle ! skip 'zero global derivatives' for counting and grouping
3177 END IF
3178 itgbi=inone( readbufferdatai(jb+j) ) ! translate to index
3179 IF (backindexusage(ioffbi+itgbi) == 0) THEN
3180 nalg=nalg+1
3181 readbufferdatai(ioff+nalg)=itgbi
3182 backindexusage(ioffbi+itgbi)=nalg
3183 END IF
3184 END DO
3185 END IF
3186 END DO
3187 ! reset back index
3188 DO j=1,nalg
3189 itgbi=readbufferdatai(ioff+j)
3190 backindexusage(ioffbi+itgbi)=0
3191 END DO
3192 ! sort (record)
3193 CALL sort1k(readbufferdatai(ioff+1),nalg)
3194 readbufferdatai(ioff)=ioff+nalg
3195 ELSE
3196 ! count per equation
3197 nalg=1 ! reserve space for counter 'nnz'
3198 ioff=readbufferpointer(ibuf)
3199 neqna=0 ! number of accepted equations
3200 DO ! loop over measurements
3201 CALL isjajb(nst,ist,ja,jb,jsp)
3202 IF(jb == 0) EXIT
3203 IF (ist > jb) THEN
3204 nnz=0 ! number of non-zero derivatives
3205 DO j=1,ist-jb
3206 IF (readbufferdatad(jb+j) == 0.0_mpd) THEN
3207 nzero=nzero+1
3208 cycle ! skip 'zero global derivatives' for counting and grouping
3209 END IF
3210 nnz=nnz+1
3211 readbufferdatai(ioff+nalg+nnz)=inone( readbufferdatai(jb+j) ) ! translate to index
3212 END DO
3213 IF (nnz == 0) cycle ! nothing for this equation
3214 readbufferdatai(ioff+nalg)=nnz
3215 ! sort (equation)
3216 CALL sort1k(readbufferdatai(ioff+nalg+1),nnz)
3217 nalg=nalg+nnz+1
3218 ! count (accepted) equations
3219 neqna=neqna+1
3220 END IF
3221 END DO
3222 readbufferdatai(ioff)=neqna
3223 END IF
3224 END DO
3225 !$OMP END PARALLEL DO
3226 nzgb=nzgb+nzero
3227
3228 !$POMP INST BEGIN(pepgrp)
3229#ifdef SCOREP_USER_ENABLE
3230 scorep_user_region_by_name_begin("UR_pepgrp", scorep_user_region_type_common)
3231#endif
3232 DO ibuf=1,numreadbuffer ! buffer for current record
3233 ist=readbufferpointer(ibuf)+1
3235 IF (mcount == 0) THEN
3236 ! equation level
3237 DO j=1,nst! loop over measurements
3238 nnz=readbufferdatai(ist)
3239 CALL pargrp(ist+1,ist+nnz)
3240 ist=ist+nnz+1
3241 END DO
3242 ELSE
3243 ! record level, group
3244 CALL pargrp(ist,nst)
3245 ENDIF
3246 END DO
3247 ! free back index
3248 IF (mcount > 0) THEN
3250 END IF
3251#ifdef SCOREP_USER_ENABLE
3252 scorep_user_region_by_name_end("UR_pepgrp")
3253#endif
3254 !$POMP INST END(pepgrp)
3255 globalparheader(-2)=0 ! reset flag to reenable further updates
3256
3257END SUBROUTINE pepgrp
3258
3266SUBROUTINE pargrp(inds,inde)
3267 USE mpmod
3268
3269 IMPLICIT NONE
3270
3271 INTEGER(mpi) :: istart
3272 INTEGER(mpi) :: itgbi
3273 INTEGER(mpi) :: j
3274 INTEGER(mpi) :: jstart
3275 INTEGER(mpi) :: jtgbi
3276 INTEGER(mpi) :: lstart
3277 INTEGER(mpi) :: ltgbi
3278
3279 INTEGER(mpi), INTENT(IN) :: inds
3280 INTEGER(mpi), INTENT(IN) :: inde
3281
3282 IF (inds > inde) RETURN
3283
3284 ltgbi=-1
3285 lstart=-1
3286 ! build up groups
3287 DO j=inds,inde
3288 itgbi=readbufferdatai(j)
3289 globalparlabelcounter(itgbi)=globalparlabelcounter(itgbi)+1 ! count entries
3290 istart=globalparlabelindex(3,itgbi) ! label of group start
3291 IF (istart == 0) THEN ! not yet in group
3292 IF (itgbi /= ltgbi+1) THEN ! start group
3294 ELSE
3295 IF (lstart == 0) THEN ! extend group
3297 ELSE ! start group
3298 globalparlabelindex(3,itgbi)=globalparlabelindex(1,itgbi)
3299 END IF
3300 END IF
3301 END IF
3302 ltgbi=itgbi
3303 lstart=istart
3304 END DO
3305 ! split groups:
3306 ! - start inside group?
3307 itgbi=readbufferdatai(inds)
3308 istart=globalparlabelindex(3,itgbi) ! label of group start
3309 jstart=globalparlabelindex(1,itgbi) ! label of first parameter
3310 IF (istart /= jstart) THEN ! start new group
3311 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3312 globalparlabelindex(3,itgbi) = jstart
3313 itgbi=itgbi+1
3314 IF (itgbi > globalparheader(-1)) EXIT
3315 END DO
3316 END IF
3317 ! - not neigbours anymore
3318 ltgbi=readbufferdatai(inds)
3319 DO j=inds+1,inde
3320 itgbi=readbufferdatai(j)
3321 IF (itgbi /= ltgbi+1) THEN
3322 ! split after ltgbi
3323 lstart=globalparlabelindex(3,ltgbi) ! label of last group start
3324 jtgbi=ltgbi+1 ! new group after ltgbi
3325 jstart=globalparlabelindex(1,jtgbi)
3326 DO WHILE (globalparlabelindex(3,jtgbi) == lstart)
3327 globalparlabelindex(3,jtgbi) = jstart
3328 jtgbi=jtgbi+1
3329 IF (jtgbi > globalparheader(-1)) EXIT
3330 IF (jtgbi == itgbi) jstart=globalparlabelindex(1,jtgbi)
3331 END DO
3332 ! split at itgbi
3333 jtgbi=itgbi
3334 istart=globalparlabelindex(3,jtgbi) ! label of group start
3335 jstart=globalparlabelindex(1,jtgbi) ! label of first parameter
3336 IF (istart /= jstart) THEN ! start new group
3337 DO WHILE (globalparlabelindex(3,jtgbi) == istart)
3338 globalparlabelindex(3,jtgbi) = jstart
3339 jtgbi=jtgbi+1
3340 IF (jtgbi > globalparheader(-1)) EXIT
3341 END DO
3342 END IF
3343 ENDIF
3344 ltgbi=itgbi
3345 END DO
3346 ! - end inside group?
3347 itgbi=readbufferdatai(inde)
3348 IF (itgbi < globalparheader(-1)) THEN
3349 istart=globalparlabelindex(3,itgbi) ! label of group start
3350 itgbi=itgbi+1
3351 jstart=globalparlabelindex(1,itgbi) ! label of new group start
3352 DO WHILE (globalparlabelindex(3,itgbi) == istart)
3353 globalparlabelindex(3,itgbi) = jstart
3354 itgbi=itgbi+1
3355 IF (itgbi > globalparheader(-1)) EXIT
3356 END DO
3357 END IF
3358
3359END SUBROUTINE pargrp
3360
3383SUBROUTINE isjajb(nst,is,ja,jb,jsp)
3384 USE mpmod
3385
3386 IMPLICIT NONE
3387
3388 INTEGER(mpi), INTENT(IN) :: nst
3389 INTEGER(mpi), INTENT(IN OUT) :: is
3390 INTEGER(mpi), INTENT(OUT) :: ja
3391 INTEGER(mpi), INTENT(OUT) :: jb
3392 INTEGER(mpi), INTENT(OUT) :: jsp
3393 SAVE
3394 ! ...
3395
3396 jsp=0
3397 DO
3398 ja=0
3399 jb=0
3400 IF(is >= nst) RETURN
3401 DO
3402 is=is+1
3403 IF(readbufferdatai(is) == 0) EXIT
3404 END DO
3405 ja=is
3406 DO
3407 is=is+1
3408 IF(readbufferdatai(is) == 0) EXIT
3409 END DO
3410 jb=is
3411 IF(ja+1 == jb.AND.readbufferdatad(jb) < 0.0_mpr8) THEN
3412 ! special data
3413 jsp=jb ! pointer to special data
3414 is=is+nint(-readbufferdatad(jb),mpi) ! skip NSP words
3415 cycle
3416 END IF
3417 DO WHILE(readbufferdatai(is+1) /= 0.AND.is < nst)
3418 is=is+1
3419 END DO
3420 EXIT
3421 END DO
3422
3423END SUBROUTINE isjajb
3424
3425
3426!***********************************************************************
3427! LOOPN ...
3433
3434SUBROUTINE loopn
3435 USE mpmod
3436
3437 IMPLICIT NONE
3438 REAL(mpd) :: dsum
3439 REAL(mps) :: elmt
3440 REAL(mpd) :: factrj
3441 REAL(mpd) :: factrk
3442 REAL(mps) :: peakd
3443 REAL(mps) :: peaki
3444 REAL(mps) :: ratae
3445 REAL(mpd) :: rhs
3446 REAL(mps) :: rloop
3447 REAL(mpd) :: sgm
3448 REAL(mps) :: used
3449 REAL(mps) :: usei
3450 REAL(mpd) :: weight
3451 INTEGER(mpi) :: i
3452 INTEGER(mpi) :: ia
3453 INTEGER(mpi) :: ib
3454 INTEGER(mpi) :: ioffb
3455 INTEGER(mpi) :: ipr
3456 INTEGER(mpi) :: itgbi
3457 INTEGER(mpi) :: itgbij
3458 INTEGER(mpi) :: itgbik
3459 INTEGER(mpi) :: ivgb
3460 INTEGER(mpi) :: ivgbij
3461 INTEGER(mpi) :: ivgbik
3462 INTEGER(mpi) :: j
3463 INTEGER(mpi) :: k
3464 INTEGER(mpi) :: lastit
3465 INTEGER(mpi) :: lun
3466 INTEGER(mpi) :: ncrit
3467 INTEGER(mpi) :: ngras
3468 INTEGER(mpi) :: nparl
3469 INTEGER(mpi) :: nr
3470 INTEGER(mpl) :: nrej
3471 INTEGER(mpi) :: inone
3472 INTEGER(mpi) :: ilow
3473 INTEGER(mpi) :: nlow
3474 INTEGER(mpi) :: nzero
3475 LOGICAL :: btest
3476
3477 REAL(mpd):: adder
3478 REAL(mpd)::funref
3479 REAL(mpd)::matij
3480
3481 SAVE
3482 ! ...
3483
3484 ! ----- book and reset ---------------------------------------------
3485 IF(nloopn == 0) THEN ! first call
3486 lastit=-1
3487 iitera=0
3488 END IF
3489
3490 nloopn=nloopn+1 ! increase loop counter
3491 funref=0.0_mpd
3492
3493 IF(nloopn == 1) THEN ! book histograms for 1. iteration
3494 CALL gmpdef(1,4,'Function value in iterations')
3495 IF (metsol == 4 .OR. metsol == 5) THEN ! extend to GMRES, i.e. 6?
3496 CALL gmpdef(2,3,'Number of MINRES steps vs iteration nr')
3497 END IF
3498 CALL hmpdef( 5,0.0,0.0,'Number of degrees of freedom')
3499 CALL hmpdef(11,0.0,0.0,'Number of local parameters')
3500 CALL hmpdef(16,0.0,24.0,'LOG10(cond(band part decomp.)) local fit ')
3501 CALL hmpdef(23,0.0,0.0, 'SQRT of diagonal elements without presigma')
3502 CALL hmpdef(24,0.0,0.0, 'Log10 of off-diagonal elements')
3503 CALL hmpdef(25,0.0,0.0, 'Relative individual pre-sigma')
3504 CALL hmpdef(26,0.0,0.0, 'Relative global pre-sigma')
3505 END IF
3506
3507
3508 CALL hmpdef(3,-prange,prange, & ! book
3509 'Normalized residuals of single (global) measurement')
3510 CALL hmpdef(12,-prange,prange, & ! book
3511 'Normalized residuals of single (local) measurement')
3512 CALL hmpdef(13,-prange,prange, & ! book
3513 'Pulls of single (global) measurement')
3514 CALL hmpdef(14,-prange,prange, & ! book
3515 'Pulls of single (local) measurement')
3516 CALL hmpdef(4,0.0,0.0,'Chi^2/Ndf after local fit')
3517 CALL gmpdef(4,5,'location, dispersion (res.) vs record nr')
3518 CALL gmpdef(5,5,'location, dispersion (pull) vs record nr')
3519
3520 ! WRITE(*,*) 'LOOPN ', NLOOPN, ' executing ICALCM=', ICALCM
3521
3522 ! reset
3523
3524 globalvector=0.0_mpd ! reset rhs vector IGVEC
3526 IF(icalcm == 1) THEN
3527 globalmatd=0.0_mpd
3528 globalmatf=0.
3529 IF (metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) matprecond=0.0_mpd
3530 END IF
3531
3532 IF(nloopn == 2) CALL hmpdef(6,0.0,0.0,'Down-weight fraction')
3533
3534 newite=.false.
3535 IF(iterat /= lastit) THEN ! new iteration
3536 newite=.true.
3537 funref=fvalue
3538 IF(nloopn > 1) THEN
3539 nrej=sum(nrejec)
3540 ! CALL MEND
3541 IF(iterat == 1) THEN
3543 ELSE IF(iterat >= 1) THEN
3544 chicut=sqrt(chicut)
3545 IF(chicut /= 0.0.AND.chicut < 1.5) chicut=1.0
3546 IF(chicut /= 0.0.AND.nrej == 0) chicut=1.0
3547 END IF
3548 END IF
3549 ! WRITE(*,111) ! header line
3550 END IF
3551
3552 nrejec=0 ! reset reject counter
3553 DO k=3,6
3554 writebufferheader(k)=0 ! cache usage
3555 writebufferheader(-k)=0
3556 END DO
3557 ! statistics per binary file
3558 DO i=1,nfilb
3559 jfd(i)=0
3560 cfd(i)=0.0
3561 dfd(i)=0
3562 END DO
3563
3564 IF (imonit /= 0) meashists=0 ! reset monitoring histograms
3565
3566 ! ----- read next data ----------------------------------------------
3567 DO
3568 CALL peread(nr) ! read records
3569 CALL peprep(1) ! prepare records
3571 IF (nr <= 0) EXIT ! next block of events ?
3572 END DO
3573 ! sum up RHS (over threads) once (reduction in LOOPBF: summation for each block)
3574 ioffb=0
3575 DO ipr=2,mthrd
3576 ioffb=ioffb+lenglobalvec
3577 DO k=1,lenglobalvec
3580 END DO
3581 END DO
3582
3583 IF (icalcm == 1) THEN
3584 ! PRINT *, ' cache/w ',(writeBufferHeader(-K),K=3,6),(writeBufferHeader(K),K=3,6)
3585 nparl=writebufferheader(3)
3586 ncrit=writebufferheader(4)
3587 used=real(writebufferheader(-5),mps)/real(writebufferheader(-3),mps)*0.1
3588 usei=real(writebufferheader(5),mps)/real(writebufferheader(3),mps)*0.1
3589 peakd=real(writebufferheader(-6),mps)*0.1
3590 peaki=real(writebufferheader(6),mps)*0.1
3591 WRITE(*,111) nparl,ncrit,usei,used,peaki,peakd
3592111 FORMAT(' Write cache usage (#flush,#overrun,<levels>,', &
3593 'peak(levels))'/2i7,',',4(f6.1,'%'))
3594 ! fill part of MINRES preconditioner matrix from binary files (formerly in mgupdt)
3595 IF (metsol >= 4.AND.metsol < 7) THEN
3596 IF (mbandw == 0) THEN
3597 ! default preconditioner (diagonal)
3598 DO i=1, nvgb
3599 matprecond(i)=matij(i,i)
3600 END DO
3601 ELSE IF (mbandw > 0) THEN
3602 ! band matrix
3603 DO i=1, nvgb
3604 ia=indprecond(i) ! index of diagonal element
3605 DO j=max(1,i-mbandw+1),i
3606 matprecond(ia-i+j)=matij(i,j)
3607 END DO
3608 END DO
3609 END IF
3610 END IF
3611 IF (ichkpg > 0) THEN
3612 ! check parameter groups
3613 CALL ckpgrp
3614 END IF
3615 END IF
3616
3617 ! check entries/counters
3618 nlow=0
3619 ilow=1
3620 nzero=0
3621 DO i=1,nvgb
3622 IF(globalcounter(i) == 0) nzero=nzero+1
3623 IF(globalcounter(i) < mreqena) THEN
3624 nlow=nlow+1
3625 IF(globalcounter(i) < globalcounter(ilow)) ilow=i
3626 END IF
3627 END DO
3628 IF(nlow > 0) THEN
3629 nalow=nalow+nlow
3630 IF(icalcm == 1) nxlow=max(nxlow,nlow) ! for matrix construction ?
3631 itgbi=globalparvartototal(ilow)
3632 print *
3633 print *, " ... warning ..."
3634 print *, " global parameters with too few (< MREQENA) accepted entries: ", nlow
3635 print *, " minimum entries: ", globalcounter(ilow), " for label ", globalparlabelindex(1,itgbi)
3636 print *
3637 END IF
3638 IF(icalcm == 1 .AND. nzero > 0) THEN
3639 ndefec = nzero ! rank defect
3640 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfgb, &
3641 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3642 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfgb, &
3643 '-by-',nfgb,' matrix is ',ndefec,' (should be zero).'
3644 IF (iforce == 0) THEN
3645 isubit=1
3646 WRITE(*,*) ' --> enforcing SUBITO mode'
3647 WRITE(lun,*) ' --> enforcing SUBITO mode'
3648 END IF
3649 END IF
3650
3651 ! ----- after end-of-data add contributions from pre-sigma ---------
3652
3653 IF(nloopn == 1) THEN
3654 ! plot diagonal elements
3655 elmt=0.0
3656 DO i=1,nvgb ! diagonal elements
3657 elmt=real(matij(i,i),mps)
3658 IF(elmt > 0.0) CALL hmpent(23,1.0/sqrt(elmt))
3659 END DO
3660 END IF
3661
3662
3663
3664 ! add pre-sigma contributions to matrix diagonal
3665
3666 ! WRITE(*,*) 'Adding to diagonal ICALCM IND6',ICALCM,IND6
3667
3668 IF(icalcm == 1) THEN
3669 DO ivgb=1,nvgb ! add evtl. pre-sigma
3670 ! WRITE(*,*) 'Index ',IVGB,IVGB,QM(IND6+IVGB)
3671 IF(globalparpreweight(ivgb) /= 0.0) THEN
3672 IF(ivgb > 0) CALL mupdat(ivgb,ivgb,globalparpreweight(ivgb))
3673 END IF
3674 END DO
3675 END IF
3676
3677 CALL hmpwrt(23)
3678 CALL hmpwrt(24)
3679 CALL hmpwrt(25)
3680 CALL hmpwrt(26)
3681
3682
3683 ! add regularization term to F and to rhs --------------------------
3684
3685 ! WRITE(*,*) 'NREGUL ',NREGUL,NLOOPN
3686
3687 IF(nregul /= 0) THEN ! add regularization term to F and to rhs
3688 DO ivgb=1,nvgb
3689 itgbi=globalparvartototal(ivgb) ! global parameter index
3691 adder=globalparpreweight(ivgb)*globalparameter(itgbi)**2
3692 CALL addsums(1, adder, 0, 1.0_mpl)
3693 END DO
3694 END IF
3695
3696
3697 ! ----- add contributions from "measurement" -----------------------
3698
3699
3700 i=1
3701 DO WHILE (i <= lenmeasurements)
3702 rhs=listmeasurements(i )%value ! right hand side
3703 sgm=listmeasurements(i+1)%value ! sigma parameter
3704 i=i+2
3705 weight=0.0
3706 IF(sgm > 0.0) weight=1.0/sgm**2
3707
3708 dsum=-rhs
3709
3710 ! loop over label/factor pairs
3711 ia=i
3712 DO
3713 i=i+1
3714 IF(i > lenmeasurements) EXIT
3715 IF(listmeasurements(i)%label < 0) EXIT
3716 END DO
3717 ib=i-1
3718
3719 DO j=ia,ib
3720 factrj=listmeasurements(j)%value
3721 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3722 IF(itgbij /= 0) THEN
3723 dsum=dsum+factrj*globalparameter(itgbij) ! update residuum
3724 END IF
3725 END DO
3726 DO j=ia,ib
3727 factrj=listmeasurements(j)%value
3728 IF (factrj == 0.0_mpd) cycle ! skip zero factors
3729 itgbij=inone(listmeasurements(j)%label) ! total parameter index
3730 ! add to vector
3731 ivgbij=0
3732 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
3733 IF(ivgbij > 0) THEN
3734 globalvector(ivgbij)=globalvector(ivgbij) -weight*dsum*factrj ! vector
3735 globalcounter(ivgbij)=globalcounter(ivgbij)+1
3736 END IF
3737
3738 IF(icalcm == 1.AND.ivgbij > 0) THEN
3739 DO k=ia,j
3740 factrk=listmeasurements(k)%value
3741 itgbik=inone(listmeasurements(k)%label) ! total parameter index
3742 ! add to matrix
3743 ivgbik=0
3744 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
3745 IF(ivgbij > 0.AND.ivgbik > 0) THEN !
3746 CALL mupdat(ivgbij,ivgbik,weight*factrj*factrk)
3747 END IF
3748 END DO
3749 END IF
3750 END DO
3751
3752 adder=weight*dsum**2
3753 CALL addsums(1, adder, 1, 1.0_mpl)
3754
3755 END DO
3756
3757 ! ----- printout ---------------------------------------------------
3758
3759
3760 ! get accurate sum (Chi^2, (w)NDF)
3762
3763 flines=0.5_mpd*fvalue ! Likelihood function value
3764 rloop=iterat+0.01*nloopn
3765 actfun=real(funref-fvalue,mps)
3766 IF(nloopn == 1) actfun=0.0
3767 ngras=nint(angras,mpi)
3768 ratae=0.0 !!!
3769 IF(delfun /= 0.0) THEN
3770 ratae=min(99.9,actfun/delfun) !!!
3771 ratae=max(-99.9,ratae)
3772 END IF
3773
3774 ! rejects ...
3775
3776 nrej =sum(nrejec)
3777 IF(nloopn == 1) THEN
3778 IF(nrej /= 0) THEN
3779 WRITE(*,*) ' '
3780 WRITE(*,*) 'Data records rejected in initial loop:'
3781 CALL prtrej(6)
3782 END IF
3783 END IF
3784
3785 IF(newite.AND.iterat == 2) THEN
3786 IF(nrecpr /= 0.OR.nrecp2 /= 0) nrecer=nrec3
3787 IF(nrecpr < 0) THEN
3789 END IF
3790 IF(nrecp2 < 0) THEN
3792 END IF
3793 END IF
3794
3795 IF(nloopn <= 2) THEN
3796 IF(nhistp /= 0) THEN
3797 ! CALL HMPRNT(3) ! scaled residual of single measurement
3798 ! CALL HMPRNT(12) ! scaled residual of single measurement
3799 ! CALL HMPRNT(4) ! chi^2/Ndf
3800 END IF
3801 CALL hmpwrt(3)
3802 CALL hmpwrt(12)
3803 CALL hmpwrt(4)
3804 CALL gmpwrt(4) ! location, dispersion (res.) as a function of record nr
3805 IF (nloopn <= lfitnp) THEN
3806 CALL hmpwrt(13)
3807 CALL hmpwrt(14)
3808 CALL gmpwrt(5) ! location, dispersion (pull) as a function of record nr
3809 END IF
3810 END IF
3811 ! IF(NLOOPN.EQ.2.AND.NHISTP.NE.0) CALL HMPRNT(6)
3812 IF(nloopn == 2) CALL hmpwrt(6)
3813 IF(nloopn <= 1) THEN
3814 ! IF(NHISTP.NE.0) CALL HMPRNT(5) ! number of degrees of freedom
3815 ! IF(NHISTP.NE.0) CALL HMPRNT(11) ! Nlocal
3816 CALL hmpwrt(5)
3817 CALL hmpwrt(11)
3818 CALL hmpwrt(16)
3819 END IF
3820
3821 ! local fit: band matrix structure !?
3822 IF (nloopn == 1.AND.nbndr(1)+nbndr(2) > 0) THEN
3823 DO lun=6,8,2
3824 WRITE(lun,*) ' '
3825 WRITE(lun,*) ' === local fits have bordered band matrix structure ==='
3826 IF (nbndr(1) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(1),'number of records (upper/left border)'
3827 IF (nbndr(2) > 0 ) WRITE(lun,101) ' NBNDR',nbndr(2),'number of records (lower/right border)'
3828 WRITE(lun,101) ' NBDRX',nbdrx,'max border size'
3829 WRITE(lun,101) ' NBNDX',nbndx,'max band width'
3830 END DO
3831 END IF
3832
3833 lastit=iterat
3834
3835 ! monitoring of residuals
3836 IF (imonit < 0 .OR. (nloopn == 1 .AND. btest(imonit,0))) CALL monres
3837
3838101 FORMAT(1x,a8,' =',i14,' = ',a)
3839! 101 FORMAT(' LOOPN',I6,' Function value',F22.8,10X,I6,' records')
3840! 102 FORMAT(' incl. constraint penalty',F22.8)
3841! 103 FORMAT(I13,3X,A,G12.4)
3842END SUBROUTINE loopn ! loop with fits
3843
3847
3848SUBROUTINE ploopa(lunp)
3849 USE mpmod
3850
3851 IMPLICIT NONE
3852
3853 INTEGER(mpi), INTENT(IN) :: lunp
3854 ! ..
3855 WRITE(lunp,*) ' '
3856 WRITE(lunp,101) ! header line
3857 WRITE(lunp,102) ! header line
3858101 FORMAT(' it fc',' fcn_value dfcn_exp slpr costh iit st', &
3859 ' ls step cutf',1x,'rejects hhmmss FMS')
3860102 FORMAT(' -- --',' ----------- -------- ---- ----- --- --', &
3861 ' -- ----- ----',1x,'------- ------ ---')
3862 RETURN
3863END SUBROUTINE ploopa ! title for iteration
3864
3868
3869SUBROUTINE ploopb(lunp)
3870 USE mpmod
3871
3872 IMPLICIT NONE
3873 INTEGER(mpi) :: ma
3874 INTEGER :: minut
3875 INTEGER(mpi) :: nfa
3876 INTEGER :: nhour
3877 INTEGER(mpl) :: nrej
3878 INTEGER(mpi) :: nsecnd
3879 REAL(mps) :: ratae
3880 REAL :: rstb
3881 REAL(mps) :: secnd
3882 REAL(mps) :: slopes(3)
3883 REAL(mps) :: steps(3)
3884 REAL, DIMENSION(2) :: ta
3885 REAl etime
3886
3887 INTEGER(mpi), INTENT(IN) :: lunp
3888
3889 CHARACTER (LEN=4):: ccalcm(4)
3890 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3891 SAVE
3892
3893 nrej=sum(nrejec) ! rejects
3894 IF(nrej > 9999999) nrej=9999999
3895 rstb=etime(ta)
3896 deltim=rstb-rstart
3897 CALL sechms(deltim,nhour,minut,secnd) ! time
3898 nsecnd=nint(secnd,mpi)
3899 IF(iterat == 0) THEN
3900 WRITE(lunp,103) iterat,nloopn,fvalue, &
3901 chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3902 ELSE
3903 IF (lsinfo == 10) THEN ! line search skipped
3904 WRITE(lunp,105) iterat,nloopn,fvalue,delfun, &
3905 iitera,istopa,chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3906 ELSE
3907 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3908 ratae=max(-99.9,min(99.9,slopes(2)/slopes(1)))
3909 stepl=steps(2)
3910 WRITE(lunp,104) iterat,nloopn,fvalue,delfun,ratae,angras, &
3911 iitera,istopa,lsinfo,stepl, chicut,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3912 ENDIF
3913 END IF
3914103 FORMAT(i3,i3,e12.5,38x,f5.1, 1x,i7, i3,i2.2,i2.2,a4)
3915104 FORMAT(i3,i3,e12.5,1x,e8.2,f6.3,f6.3,i5,2i3,f6.3,f5.1, &
3916 1x,i7, i3,i2.2,i2.2,a4)
3917105 FORMAT(i3,i3,e12.5,1x,e8.2,12x,i5,i3,9x,f5.1, &
3918 1x,i7, i3,i2.2,i2.2,a4)
3919 RETURN
3920END SUBROUTINE ploopb ! iteration line
3921
3925
3926SUBROUTINE ploopc(lunp)
3927 USE mpmod
3928
3929 IMPLICIT NONE
3930 INTEGER(mpi) :: ma
3931 INTEGER(mpi) :: minut
3932 INTEGER(mpi) :: nfa
3933 INTEGER(mpi) :: nhour
3934 INTEGER(mpl) :: nrej
3935 INTEGER(mpi) :: nsecnd
3936 REAL(mps) :: ratae
3937 REAL :: rstb
3938 REAL(mps) :: secnd
3939 REAL(mps) :: slopes(3)
3940 REAL(mps) :: steps(3)
3941 REAL, DIMENSION(2) :: ta
3942 REAL etime
3943
3944 INTEGER(mpi), INTENT(IN) :: lunp
3945 CHARACTER (LEN=4):: ccalcm(4)
3946 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3947 SAVE
3948
3949 nrej=sum(nrejec) ! rejects
3950 IF(nrej > 9999999) nrej=9999999
3951 rstb=etime(ta)
3952 deltim=rstb-rstart
3953 CALL sechms(deltim,nhour,minut,secnd) ! time
3954 nsecnd=nint(secnd,mpi)
3955 IF (lsinfo == 10) THEN ! line search skipped
3956 WRITE(lunp,104) nloopn,fvalue,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3957 ELSE
3958 CALL ptlopt(nfa,ma,slopes,steps) ! slopes steps
3959 ratae=abs(slopes(2)/slopes(1))
3960 stepl=steps(2)
3961 WRITE(lunp,105) nloopn,fvalue, ratae,lsinfo, &
3962 stepl,nrej,nhour,minut,nsecnd,ccalcm(lcalcm)
3963 END IF
3964104 FORMAT(3x,i3,e12.5,9x, 35x, i7, i3,i2.2,i2.2,a4)
3965105 FORMAT(3x,i3,e12.5,9x, f6.3,14x,i3,f6.3,6x, i7, i3,i2.2,i2.2,a4)
3966 RETURN
3967
3968END SUBROUTINE ploopc ! sub-iteration line
3969
3973
3974SUBROUTINE ploopd(lunp)
3975 USE mpmod
3976 IMPLICIT NONE
3977 INTEGER :: minut
3978 INTEGER :: nhour
3979 INTEGER(mpi) :: nsecnd
3980 REAL :: rstb
3981 REAL(mps) :: secnd
3982 REAL, DIMENSION(2) :: ta
3983 REAL etime
3984
3985 INTEGER(mpi), INTENT(IN) :: lunp
3986 CHARACTER (LEN=4):: ccalcm(4)
3987 DATA ccalcm / ' end',' S', ' F ',' FMS' /
3988 SAVE
3989 rstb=etime(ta)
3990 deltim=rstb-rstart
3991 CALL sechms(deltim,nhour,minut,secnd) ! time
3992 nsecnd=nint(secnd,mpi)
3993
3994 WRITE(lunp,106) nhour,minut,nsecnd,ccalcm(lcalcm)
3995106 FORMAT(69x,i3,i2.2,i2.2,a4)
3996 RETURN
3997END SUBROUTINE ploopd
3998
4000SUBROUTINE explfc(lunit)
4001 USE mpdef
4002 USE mpmod, ONLY: metsol
4003
4004 IMPLICIT NONE
4005 INTEGER(mpi) :: lunit
4006 WRITE(lunit,*) ' '
4007 WRITE(lunit,102) 'Explanation of iteration table'
4008 WRITE(lunit,102) '=============================='
4009 WRITE(lunit,101) 'it', &
4010 'iteration number. Global parameters are improved for it > 0.'
4011 WRITE(lunit,102) 'First function evaluation is called iteraton 0.'
4012 WRITE(lunit,101) 'fc', 'number of function evaluations.'
4013 WRITE(lunit,101) 'fcn_value', 'value of 2 x Likelihood function (LF).'
4014 WRITE(lunit,102) 'The final value is the chi^2 value of the fit and should'
4015 WRITE(lunit,102) 'be about equal to the NDF (see below).'
4016 WRITE(lunit,101) 'dfcn_exp', &
4017 'expected reduction of the value of the Likelihood function (LF)'
4018 WRITE(lunit,101) 'slpr', 'ratio of the actual slope to inital slope.'
4019 WRITE(lunit,101) 'costh', &
4020 'cosine of angle between search direction and -gradient'
4021 IF (metsol == 4) THEN
4022 WRITE(lunit,101) 'iit', &
4023 'number of internal iterations in MINRES algorithm'
4024 WRITE(lunit,101) 'st', 'stop code of MINRES algorithm'
4025 WRITE(lunit,102) '< 0: rhs is very special, with beta2 = 0'
4026 WRITE(lunit,102) '= 0: rhs b = 0, i.e. the exact solution is x = 0'
4027 WRITE(lunit,102) '= 1 requested accuracy achieved, as determined by rtol'
4028 WRITE(lunit,102) '= 2 reasonable accuracy achieved, given eps'
4029 WRITE(lunit,102) '= 3 x has converged to an eigenvector'
4030 WRITE(lunit,102) '= 4 matrix ill-conditioned (Acond has exceeded 0.1/eps)'
4031 WRITE(lunit,102) '= 5 the iteration limit was reached'
4032 WRITE(lunit,102) '= 6 Matrix x vector does not define a symmetric matrix'
4033 WRITE(lunit,102) '= 7 Preconditioner does not define a symmetric matrix'
4034 ELSEIF (metsol == 5) THEN
4035 WRITE(lunit,101) 'iit', &
4036 'number of internal iterations in MINRES-QLP algorithm'
4037 WRITE(lunit,101) 'st', 'stop code of MINRES-QLP algorithm'
4038 WRITE(lunit,102) '= 1: beta_{k+1} < eps, iteration k is the final Lanczos step.'
4039 WRITE(lunit,102) '= 2: beta2 = 0. If M = I, b and x are eigenvectors of A.'
4040 WRITE(lunit,102) '= 3: beta1 = 0. The exact solution is x = 0.'
4041 WRITE(lunit,102) '= 4: A solution to (poss. singular) Ax = b found, given rtol.'
4042 WRITE(lunit,102) '= 5: A solution to (poss. singular) Ax = b found, given eps.'
4043 WRITE(lunit,102) '= 6: Pseudoinverse solution for singular LS problem, given rtol.'
4044 WRITE(lunit,102) '= 7: Pseudoinverse solution for singular LS problem, given eps.'
4045 WRITE(lunit,102) '= 8: The iteration limit was reached.'
4046 WRITE(lunit,102) '= 9: The operator defined by Aprod appears to be unsymmetric.'
4047 WRITE(lunit,102) '=10: The operator defined by Msolve appears to be unsymmetric.'
4048 WRITE(lunit,102) '=11: The operator defined by Msolve appears to be indefinite.'
4049 WRITE(lunit,102) '=12: xnorm has exceeded maxxnorm or will exceed it next iteration.'
4050 WRITE(lunit,102) '=13: Acond has exceeded Acondlim or 0.1/eps.'
4051 WRITE(lunit,102) '=14: Least-squares problem but no converged solution yet.'
4052 WRITE(lunit,102) '=15: A null vector obtained, given rtol.'
4053 ENDIF
4054 WRITE(lunit,101) 'ls', 'line search info'
4055 WRITE(lunit,102) '< 0 recalculate function'
4056 WRITE(lunit,102) '= 0: N or STP lt 0 or step not descending'
4057 WRITE(lunit,102) '= 1: Linesearch convergence conditions reached'
4058 WRITE(lunit,102) '= 2: interval of uncertainty at lower limit'
4059 WRITE(lunit,102) '= 3: max nr of line search calls reached'
4060 WRITE(lunit,102) '= 4: step at the lower bound'
4061 WRITE(lunit,102) '= 5: step at the upper bound'
4062 WRITE(lunit,102) '= 6: rounding error limitation'
4063 WRITE(lunit,101) 'step', &
4064 'the factor for the Newton step during the line search. Usually'
4065 WRITE(lunit,102) &
4066 'a value of 1 gives a sufficient reduction of the LF. Oherwise'
4067 WRITE(lunit,102) 'other step values are tried.'
4068 WRITE(lunit,101) 'cutf', &
4069 'cut factor. Local fits are rejected, if their chi^2 value'
4070 WRITE(lunit,102) &
4071 'is larger than the 3-sigma chi^2 value times the cut factor.'
4072 WRITE(lunit,102) 'A cut factor of 1 is used finally, but initially a larger'
4073 WRITE(lunit,102) 'factor may be used. A value of 0.0 means no cut.'
4074 WRITE(lunit,101) 'rejects', 'total number of rejected local fits.'
4075 WRITE(lunit,101) 'hmmsec', 'the time in hours (h), minutes (mm) and seconds.'
4076 WRITE(lunit,101) 'FMS', 'calculation of Function value, Matrix, Solution.'
4077 WRITE(lunit,*) ' '
4078
4079101 FORMAT(a9,' = ',a)
4080102 FORMAT(13x,a)
4081END SUBROUTINE explfc
4082
4090
4091SUBROUTINE mupdat(i,j,add) !
4092 USE mpmod
4093
4094 IMPLICIT NONE
4095
4096 INTEGER(mpi), INTENT(IN) :: i
4097 INTEGER(mpi), INTENT(IN) :: j
4098 REAL(mpd), INTENT(IN) :: add
4099
4100 INTEGER(mpl):: ijadd
4101 INTEGER(mpl):: ijcsr3
4102 INTEGER(mpl):: ia
4103 INTEGER(mpl):: ja
4104 INTEGER(mpl):: ij
4105 ! ...
4106 IF(i <= 0.OR.j <= 0.OR. add == 0.0_mpd) RETURN
4107 ia=max(i,j) ! larger
4108 ja=min(i,j) ! smaller
4109 ij=0
4110 IF(matsto == 3) THEN
4111 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
4112 ij=ijcsr3(i,j) ! inline code requires same time
4113 IF (ij > 0) globalmatd(ij)=globalmatd(ij)+add
4114 RETURN
4115 ELSE ! sparse symmetric matrix (BSR3)
4116 ! block index
4117 ij=ijcsr3((i-1)/matbsz+1,(j-1)/matbsz+1)
4118 IF (ij > 0) THEN
4119 ! index of first element in block
4120 ij=(ij-1)*matbsz*matbsz+1
4121 ! adjust index for position in block
4122 ij=ij+mod(int(ia-1,mpi),matbsz)*matbsz+mod(int(ja-1,mpi),matbsz)
4123 globalmatd(ij)=globalmatd(ij)+add
4124 ENDIF
4125 RETURN
4126 END IF
4127 ELSE IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4128 ij=ijadd(i,j) ! inline code requires same time
4129 IF (ij == 0) RETURN ! pair is suppressed
4130 IF (ij > 0) THEN
4131 globalmatd(ij)=globalmatd(ij)+add
4132 ELSE
4133 globalmatf(-ij)=globalmatf(-ij)+real(add,mps)
4134 END IF
4135 ELSE ! full or unpacked (block diagonal) symmetric matrix
4136 ! global (ia,ib) to local (row,col) in block
4137 ij=globalrowoffsets(ia)+ja
4138 globalmatd(ij)=globalmatd(ij)+add
4139 END IF
4140 ! MINRES preconditioner
4141 IF(metsol >= 4.AND.metsol < 7.AND.mbandw >= 0) THEN
4142 ij=0 ! no update
4143 IF(ia <= nvgb) THEN ! variable global parameter
4144 IF(mbandw > 0) THEN ! band matrix for Cholesky decomposition
4145 ij=indprecond(ia)-ia+ja
4146 IF(ia > 1.AND.ij <= indprecond(ia-1)) ij=0
4147 ELSE ! default preconditioner (diagonal)
4148 IF(ja == ia) ij=ia
4149 END IF
4150 ELSE ! Lagrange multiplier
4151 ij=offprecond(ia-nvgb)+ja
4152 END IF
4153 ! bad index?
4154 IF(ij < 0.OR.ij > size(matprecond)) THEN
4155 CALL peend(23,'Aborted, bad matrix index')
4156 stop 'mupdat: bad index'
4157 END IF
4158 ! update?
4159 IF(ij /= 0) matprecond(ij)=matprecond(ij)+add
4160 END IF
4161END SUBROUTINE mupdat
4162
4163
4175
4176SUBROUTINE mgupdt(i,j1,j2,il,jl,n,sub)
4177 USE mpmod
4178
4179 IMPLICIT NONE
4180
4181 INTEGER(mpi), INTENT(IN) :: i
4182 INTEGER(mpi), INTENT(IN) :: j1
4183 INTEGER(mpi), INTENT(IN) :: j2
4184 INTEGER(mpi), INTENT(IN) :: il
4185 INTEGER(mpi), INTENT(IN) :: jl
4186 INTEGER(mpi), INTENT(IN) :: n
4187 REAL(mpd), INTENT(IN) :: sub((n*n+n)/2)
4188
4189 INTEGER(mpl):: ij
4190 INTEGER(mpl):: ioff
4191 INTEGER(mpi):: ia
4192 INTEGER(mpi):: ia1
4193 INTEGER(mpi):: ib
4194 INTEGER(mpi):: iblast
4195 INTEGER(mpi):: iblock
4196 INTEGER(mpi):: ijl
4197 INTEGER(mpi):: iprc
4198 INTEGER(mpi):: ir
4199 INTEGER(mpi):: ja
4200 INTEGER(mpi):: jb
4201 INTEGER(mpi):: jblast
4202 INTEGER(mpi):: jblock
4203 INTEGER(mpi):: jc
4204 INTEGER(mpi):: jc1
4205 INTEGER(mpi):: jpg
4206 INTEGER(mpi):: k
4207 INTEGER(mpi):: lr
4208 INTEGER(mpi):: nc
4209
4210 INTEGER(mpl) ijcsr3
4211 ! ...
4212 IF(i <= 0.OR.j1 <= 0.OR.j2 > i) RETURN
4213
4214 IF(matsto == 3) THEN ! sparse symmetric matrix (CSR3, upper triangle)
4215 ja=globalallindexgroups(i) ! first (global) column
4216 jb=globalallindexgroups(i+1)-1 ! last (global) column
4217 ia1=globalallindexgroups(j1) ! first (global) row
4218 ! loop over groups (now in same column)
4219 DO jpg=j1,j2
4220 ia=globalallindexgroups(jpg) ! first (global) row in group
4221 ib=globalallindexgroups(jpg+1)-1 ! last (global) row in group
4222 IF (matbsz < 2) THEN
4223 ! CSR3
4224 ij=ijcsr3(ia,ja)
4225 IF (ij == 0) THEN
4226 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc, matsto
4227 stop
4228 END IF
4229 ioff=ij-ja ! offset
4230 DO ir=ia,ib
4231 jc1=max(ir,ja)
4232 k=il+jc1-ja
4233 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4234 DO jc=jc1,jb
4235 globalmatd(ioff+jc)=globalmatd(ioff+jc)-sub(ijl)
4236 ijl=ijl+k
4237 k=k+1
4238 END DO
4239 ioff=ioff+csr3rowoffsets(ir+1)-csr3rowoffsets(ir)-1
4240 END DO
4241 ELSE
4242 ! BSR3
4243 iblast=-1
4244 jblast=-1
4245 ioff=0
4246 DO ir=ia,ib
4247 iblock=(ir-1)/matbsz+1
4248 jc1=max(ir,ja)
4249 k=il+jc1-ja
4250 ijl=(k*k-k)/2+jl+ir-ia1 ! ISYM index offset (subtrahends matrix)
4251 DO jc=jc1,jb
4252 jblock=(jc-1)/matbsz+1
4253 ! index of first element in (new) block
4254 IF (jblock /= jblast.OR.iblock /= iblast) THEN
4255 ioff=(ijcsr3(iblock,jblock)-1)*matbsz*matbsz+1
4256 iblast=iblock
4257 jblast=jblock
4258 END IF
4259 ! adjust index for position in block
4260 ij=ioff+mod(int(ir-1,mpi),matbsz)+mod(int(jc-1,mpi),matbsz)*matbsz
4261 globalmatd(ij)=globalmatd(ij)-sub(ijl)
4262 ijl=ijl+k
4263 k=k+1
4264 END DO
4265 END DO
4266 END IF
4267 END DO
4268 RETURN
4269 END IF
4270
4271 ! lower triangle
4272 ia=globalallindexgroups(i) ! first (global) row
4273 ib=globalallindexgroups(i+1)-1 ! last (global) row
4274 ja=globalallindexgroups(j1) ! first (global) column
4275 jb=globalallindexgroups(j2+1)-1 ! last (global) column
4276
4277 IF(matsto == 2) THEN ! sparse symmetric matrix (custom)
4278 CALL ijpgrp(i,j1,ij,lr,iprc) ! index of first element of group 'j1'
4279 IF (ij == 0) THEN
4280 print *, ' MGUPDT: ij=0', i,j1,j2,il,jl,ij,lr,iprc,matsto
4281 stop
4282 END IF
4283 k=il
4284 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4285 DO ir=ia,ib
4286 nc=min(ir,jb)-ja ! number of columns -1
4287 IF (jb >= ir) THEN ! diagonal element
4288 globalmatd(ir)=globalmatd(ir)-sub(ijl+jl+nc)
4289 nc=nc-1
4290 END IF
4291 ! off-diagonal elements
4292 IF (iprc == 1) THEN
4293 globalmatd(ij:ij+nc)=globalmatd(ij:ij+nc)-sub(ijl+jl:ijl+jl+nc)
4294 ELSE
4295 globalmatf(ij:ij+nc)=globalmatf(ij:ij+nc)-real(sub(ijl+jl:ijl+jl+nc),mps)
4296 END IF
4297 ij=ij+lr
4298 ijl=ijl+k
4299 k=k+1
4300 END DO
4301 ELSE ! full or unpacked (block diagonal) symmetric matrix
4302 k=il
4303 ijl=(k*k-k)/2 ! ISYM index offset (subtrahends matrix)
4304 DO ir=ia,ib
4305 ! global (ir,0) to local (row,col) in block
4306 ij=globalrowoffsets(ir)
4307 nc=min(ir,jb)-ja ! number of columns -1
4308 globalmatd(ij+ja:ij+ja+nc)=globalmatd(ij+ja:ij+ja+nc)-sub(ijl+jl:ijl+jl+nc)
4309 ijl=ijl+k
4310 k=k+1
4311 END DO
4312 END IF
4313
4314END SUBROUTINE mgupdt
4315
4316
4343
4344SUBROUTINE loopbf(nrej,numfil,naccf,chi2f,ndff)
4345 USE mpmod
4346
4347 IMPLICIT NONE
4348 REAL(mpd) :: cauchy
4349 REAL(mps) :: chichi
4350 REAL(mps) :: chlimt
4351 REAL(mps) :: chndf
4352 REAL(mpd) :: chuber
4353 REAL(mpd) :: down
4354 REAL(mpd) :: pull
4355 REAL(mpd) :: r1
4356 REAL(mpd) :: r2
4357 REAL(mps) :: rec
4358 REAL(mpd) :: rerr
4359 REAL(mpd) :: resid
4360 REAL(mps) :: resing
4361 REAL(mpd) :: resmax
4362 REAL(mpd) :: rmeas
4363 REAL(mpd) :: rmloc
4364 REAL(mpd) :: suwt
4365 REAL(mps) :: used
4366 REAL(mpd) :: wght
4367 REAL(mps) :: chindl
4368 INTEGER(mpi) :: i
4369 INTEGER(mpi) :: ia
4370 INTEGER(mpi) :: ib
4371 INTEGER(mpi) :: ibuf
4372 INTEGER(mpi) :: ichunk
4373 INTEGER(mpl) :: icmn
4374 INTEGER(mpl) :: icost
4375 INTEGER(mpi) :: id
4376 INTEGER(mpi) :: idiag
4377 INTEGER(mpi) :: ieq
4378 INTEGER(mpi) :: iext
4379 INTEGER(mpi) :: ij
4380 INTEGER(mpi) :: ije
4381 INTEGER(mpi) :: ijn
4382 INTEGER(mpi) :: ik
4383 INTEGER(mpi) :: ike
4384 INTEGER(mpi) :: il
4385 INTEGER(mpi) :: im
4386 INTEGER(mpi) :: imeas
4387 INTEGER(mpi) :: in
4388 INTEGER(mpi) :: inv
4389 INTEGER(mpi) :: ioffb
4390 INTEGER(mpi) :: ioffc
4391 INTEGER(mpi) :: ioffd
4392 INTEGER(mpi) :: ioffe
4393 INTEGER(mpi) :: ioffi
4394 INTEGER(mpi) :: ioffq
4395 INTEGER(mpi) :: iprc
4396 INTEGER(mpi) :: iprcnx
4397 INTEGER(mpi) :: iprdbg
4398 INTEGER(mpi) :: iproc
4399 INTEGER(mpi) :: irbin
4400 INTEGER(mpi) :: isize
4401 INTEGER(mpi) :: ist
4402 INTEGER(mpi) :: iter
4403 INTEGER(mpi) :: itgbi
4404 INTEGER(mpi) :: ivgbj
4405 INTEGER(mpi) :: ivgbk
4406 INTEGER(mpi) :: ivpgrp
4407 INTEGER(mpi) :: j
4408 INTEGER(mpi) :: j1
4409 INTEGER(mpi) :: ja
4410 INTEGER(mpi) :: jb
4411 INTEGER(mpi) :: jk
4412 INTEGER(mpi) :: jl
4413 INTEGER(mpi) :: jl1
4414 INTEGER(mpi) :: jn
4415 INTEGER(mpi) :: jnx
4416 INTEGER(mpi) :: joffd
4417 INTEGER(mpi) :: joffi
4418 INTEGER(mpi) :: jproc
4419 INTEGER(mpi) :: jrc
4420 INTEGER(mpi) :: jsp
4421 INTEGER(mpi) :: k
4422 INTEGER(mpi) :: kbdr
4423 INTEGER(mpi) :: kbdrx
4424 INTEGER(mpi) :: kbnd
4425 INTEGER(mpi) :: kfl
4426 INTEGER(mpi) :: kx
4427 INTEGER(mpi) :: lvpgrp
4428 INTEGER(mpi) :: mbdr
4429 INTEGER(mpi) :: mbnd
4430 INTEGER(mpi) :: mside
4431 INTEGER(mpi) :: nalc
4432 INTEGER(mpi) :: nalg
4433 INTEGER(mpi) :: nan
4434 INTEGER(mpi) :: nb
4435 INTEGER(mpi) :: ndf
4436 INTEGER(mpi) :: ndown
4437 INTEGER(mpi) :: neq
4438 INTEGER(mpi) :: nfred
4439 INTEGER(mpi) :: nfrei
4440 INTEGER(mpi) :: ngg
4441 INTEGER(mpi) :: nprdbg
4442 INTEGER(mpi) :: nrank
4443 INTEGER(mpl) :: nrc
4444 INTEGER(mpi) :: nst
4445 INTEGER(mpi) :: nter
4446 INTEGER(mpi) :: nweig
4447 INTEGER(mpi) :: ngrp
4448 INTEGER(mpi) :: npar
4449
4450 INTEGER(mpl), INTENT(IN OUT) :: nrej(6)
4451 INTEGER(mpi), INTENT(IN) :: numfil
4452 INTEGER(mpi), INTENT(IN OUT) :: naccf(numfil)
4453 REAL(mps), INTENT(IN OUT) :: chi2f(numfil)
4454 INTEGER(mpi), INTENT(IN OUT) :: ndff(numfil)
4455
4456 REAL(mps) :: cndl10
4457 REAL(mpd) :: dchi2
4458 REAL(mpd) :: dvar
4459 REAL(mpd) :: dw1
4460 REAL(mpd) :: dw2
4461 REAL(mpd) :: evdmin
4462 REAL(mpd) :: evdmax
4463 REAL(mpd) :: summ
4464 INTEGER(mpi) :: ijprec
4465
4466 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
4467
4468 LOGICAL:: lprnt
4469 LOGICAL::lhist
4470
4471 CHARACTER (LEN=3):: chast
4472 DATA chuber/1.345_mpd/ ! constant for Huber down-weighting
4473 DATA cauchy/2.3849_mpd/ ! constant for Cauchy down-weighting
4474 SAVE chuber,cauchy
4475 ! ...
4476
4477 ichunk=min((numreadbuffer+mthrd-1)/mthrd/32+1,256)
4478 ! reset header, 3 words per thread:
4479 ! number of entries, offset to data, indices
4482 nprdbg=0
4483 iprdbg=-1
4484
4485 ! parallelize record loop
4486 ! private copy of NREJ,.. for each thread, combined at end, init with 0.
4487 !$OMP PARALLEL DO &
4488 !$OMP DEFAULT(PRIVATE) &
4489 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI, &
4490 !$OMP readBufferDataD,writeBufferHeader,writeBufferInfo, &
4491 !$OMP writeBufferData,writeBufferIndices,writeBufferUpdates,globalVector,globalCounter, &
4492 !$OMP globalParameter,globalParLabelIndex,globalIndexUsage,backIndexUsage, &
4493 !$OMP measBins,numMeas,measIndex,measRes,measHists,globalAllParToGroup,globalAllIndexGroups, &
4494 !$OMP localCorrections,localEquations,ifd, &
4495 !$OMP NAGB,NVGB,NAGBN,ICALCM,ICHUNK,NLOOPN,NRECER,NPRDBG,IPRDBG, &
4496 !$OMP NEWITE,CHICUT,LHUBER,CHUBER,ITERAT,NRECPR,MTHRD,NSPC,NAEQN, &
4497 !$OMP DWCUT,CHHUGE,NRECP2,CAUCHY,LFITNP,LFITBB,IMONIT,IMONMD,MONPG1,LUNLOG,MDEBUG,CNDLMX) &
4498 !$OMP REDUCTION(+:NREJ,NBNDR,NACCF,CHI2F,NDFF) &
4499 !$OMP REDUCTION(MAX:NBNDX,NBDRX) &
4500 !$OMP REDUCTION(MIN:NREC3) &
4501 !$OMP SCHEDULE(DYNAMIC,ICHUNK)
4502 DO ibuf=1,numreadbuffer ! buffer for current record
4503 jrc=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
4504 kfl=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
4505 nrc=ifd(kfl)+jrc ! global record number
4506 dw1=real(readbufferdatad(readbufferpointer(ibuf)-1),mpd) ! weight
4507 dw2=sqrt(dw1)
4508
4509 iproc=0
4510 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
4511 ioffb=nagb*iproc ! offset 'f'.
4512 ioffc=nagbn*iproc ! offset 'c'.
4513 ioffe=nvgb*iproc ! offset 'e'
4514 ioffd=writebufferheader(-1)*iproc+writebufferinfo(2,iproc+1) ! offset data
4515 ioffi=writebufferheader(1)*iproc+writebufferinfo(3,iproc+1)+3 ! offset indices
4516 ioffq=naeqn*iproc ! offset equations (measurements)
4517 ! ----- reset ------------------------------------------------------
4518 lprnt=.false.
4519 lhist=(iproc == 0)
4520 rec=real(nrc,mps) ! floating point value
4521 IF(nloopn == 1.AND.mod(nrc,100000_mpl) == 0) THEN
4522 WRITE(*,*) 'Record',nrc,' ... still reading'
4523 IF(monpg1>0) WRITE(lunlog,*) 'Record',nrc,' ... still reading'
4524 END IF
4525
4526 ! printout/debug only for one thread at a time
4527
4528
4529 ! flag for record printout -----------------------------------------
4530
4531 lprnt=.false.
4532 IF(newite.AND.(iterat == 1.OR.iterat == 3)) THEN
4533 IF(nrc == nrecpr) lprnt=.true.
4534 IF(nrc == nrecp2) lprnt=.true.
4535 IF(nrc == nrecer) lprnt=.true.
4536 END IF
4537 IF (lprnt)THEN
4538 !$OMP ATOMIC
4539 nprdbg=nprdbg+1 ! number of threads with debug
4540 IF (nprdbg == 1) iprdbg=iproc ! first thread with debug
4541 IF (iproc /= iprdbg) lprnt=.false.
4542 ! print *, ' LPRNT ', NRC, NPRDBG, IPRDBG, IPROC, LPRNT
4543 END IF
4544 IF(lprnt) THEN
4545 WRITE(1,*) ' '
4546 WRITE(1,*) '------------------ Loop',nloopn, &
4547 ': Printout for record',nrc,iproc
4548 WRITE(1,*) ' '
4549 END IF
4550
4551 ! ----- print data -------------------------------------------------
4552
4553 IF(lprnt) THEN
4554 imeas=0 ! local derivatives
4555 ist=readbufferpointer(ibuf)+1
4557 DO ! loop over measurements
4558 CALL isjajb(nst,ist,ja,jb,jsp)
4559 IF(ja == 0) EXIT
4560 IF(imeas == 0) WRITE(1,1121)
4561 imeas=imeas+1
4562 WRITE(1,1122) imeas,readbufferdatad(ja),readbufferdatad(jb), &
4563 (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
4564 END DO
45651121 FORMAT(/'Measured value and local derivatives'/ &
4566 ' i measured std_dev index...derivative ...')
45671122 FORMAT(i3,2g12.4,3(i3,g12.4)/(27x,3(i3,g12.4)))
4568
4569 imeas=0 ! global derivatives
4570 ist=readbufferpointer(ibuf)+1
4572 DO ! loop over measurements
4573 CALL isjajb(nst,ist,ja,jb,jsp)
4574 IF(ja == 0) EXIT
4575 IF(imeas == 0) WRITE(1,1123)
4576 imeas=imeas+1
4577 IF (jb < ist) THEN
4578 IF(ist-jb > 2) THEN
4579 WRITE(1,1124) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4580 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4581 ELSE
4582 WRITE(1,1125) imeas,(globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
4583 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
4584 END IF
4585 END IF
4586 END DO
45871123 FORMAT(/'Global derivatives'/ &
4588 ' i label gindex vindex derivative ...')
45891124 FORMAT(i3,2(i9,i7,i7,g12.4)/(3x,2(i9,i7,i7,g12.4)))
45901125 FORMAT(i3,2(i9,i7,i7,g12.4))
4591 END IF
4592
4593 ! ----- first loop -------------------------------------------------
4594 ! ------ prepare local fit ------
4595 ! count local and global derivates
4596 ! subtract actual alignment parameters from the measured data
4597
4598 IF(lprnt) THEN
4599 WRITE(1,*) ' '
4600 WRITE(1,*) 'Data corrections using values of global parameters'
4601 WRITE(1,*) '=================================================='
4602 WRITE(1,101)
4603 END IF
4604 nalg=0 ! count number of global derivatives
4605 nalc=0 ! count number of local derivatives
4606 neq=0 ! count number of equations
4607
4608 ist=readbufferpointer(ibuf)+1
4610 DO ! loop over measurements
4611 CALL isjajb(nst,ist,ja,jb,jsp)
4612 IF(ja == 0) EXIT
4613 rmeas=real(readbufferdatad(ja),mpd) ! data
4614 neq=neq+1 ! count equation
4615 localequations(1,ioffq+neq)=ja
4616 localequations(2,ioffq+neq)=jb
4617 localequations(3,ioffq+neq)=ist
4618 ! subtract global ... from measured value
4619 DO j=1,ist-jb ! global parameter loop
4620 itgbi=readbufferdatai(jb+j) ! global parameter label
4621 rmeas=rmeas-real(readbufferdatad(jb+j),mpd)*globalparameter(itgbi) ! subtract !!! reversed
4622 IF (icalcm == 1) THEN
4623 ij=globalparlabelindex(2,itgbi) ! -> index of variable global parameter
4624 IF(ij > 0) THEN
4625 ijn=backindexusage(ioffe+ij) ! get index of index
4626 IF(ijn == 0) THEN ! not yet included
4627 nalg=nalg+1 ! count
4628 globalindexusage(ioffc+nalg)=ij ! store global index
4629 backindexusage(ioffe+ij)=nalg ! store back index
4630 END IF
4631 END IF
4632 END IF
4633 END DO
4634 IF(lprnt) THEN
4635 IF (jb < ist) WRITE(1,102) neq,readbufferdatad(ja),rmeas,readbufferdatad(jb)
4636 END IF
4637 readbufferdatad(ja)=real(rmeas,mpr8) ! global contribution subtracted
4638 DO j=1,jb-ja-1 ! local parameter loop
4639 ij=readbufferdatai(ja+j)
4640 nalc=max(nalc,ij) ! number of local parameters
4641 END DO
4642 END DO
4643101 FORMAT(' index measvalue corrvalue sigma')
4644102 FORMAT(i6,2x,2g12.4,' +-',g12.4)
4645
4646 IF(nalc <= 0) GO TO 90
4647
4648 ngg=(nalg*nalg+nalg)/2
4649 ngrp=0
4650 IF (icalcm == 1) THEN
4651 localglobalmatrix(:nalg*nalc)=0.0_mpd ! reset global-local matrix
4652 localglobalmap(:nalg*nalc)=0 ! reset global-local map
4653 ! store parameter group indices
4654 CALL sort1k(globalindexusage(ioffc+1),nalg) ! sort global par.
4655 lvpgrp=-1
4656 npar=0
4657 DO k=1,nalg
4658 iext=globalindexusage(ioffc+k)
4659 backindexusage(ioffe+iext)=k ! update back index
4660 ivpgrp=globalallpartogroup(iext) ! group
4661 IF (ivpgrp /= lvpgrp) THEN
4662 ngrp=ngrp+1
4663 writebufferindices(ioffi+ngrp)=ivpgrp ! global par group indices
4664 lvpgrp=ivpgrp
4665 npar=npar+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4666 END IF
4667 END DO
4668 ! check NPAR==NALG
4669 IF (npar /= nalg) THEN
4670 print *, ' mismatch of number of global parameters ', nrc, nalg, npar, ngrp
4671 print *, globalindexusage(ioffc+1:ioffc+nalg)
4672 print *, writebufferindices(ioffi+1:ioffi+ngrp)
4673 j=0
4674 DO k=1,ngrp
4675 ivpgrp=writebufferindices(ioffi+k)
4676 j=j+globalallindexgroups(ivpgrp+1)-globalallindexgroups(ivpgrp)
4677 IF (globalallpartogroup(globalindexusage(ioffc+j)) /= ivpgrp) &
4678 print *, ' bad group ', k, j, ivpgrp, globalindexusage(ioffc+j)
4679 END DO
4680 CALL peend(35,'Aborted, mismatch of number of global parameters')
4681 stop ' mismatch of number of global parameters '
4682 ENDIF
4683 ! index header
4684 writebufferindices(ioffi-2)=jrc ! record number in file
4685 writebufferindices(ioffi-1)=nalg ! number of global parameters
4686 writebufferindices(ioffi )=ngrp ! number of global par groups
4687 DO k=1,ngg
4688 writebufferupdates(ioffd+k)=0.0_mpd ! reset global-global matrix
4689 END DO
4690 END IF
4691 ! ----- iteration start and check ---------------------------------
4692
4693 nter=1 ! first loop without down-weighting
4694 IF(nloopn /= 1.AND.lhuber /= 0) nter=lhuber
4695 localcorrections(ioffq+1:ioffq+neq) = 0._mpd
4696
4697 ! check matrix for bordered band structure (MBDR+MBND+1 <= NALC)
4698 mbnd=-1
4699 mbdr=nalc
4700 mside=-1 ! side (1: upper/left border, 2: lower/right border)
4701 DO i=1, 2*nalc
4702 ibandh(i)=0
4703 END DO
4704 idiag=1
4705
4706 iter=0
4707 resmax=0.0
4708 DO WHILE(iter < nter) ! outlier suppresssion iteration loop
4709 iter=iter+1
4710 resmax=0.0
4711 IF(lprnt) THEN
4712 WRITE(1,*) ' '
4713 WRITE(1,*) 'Outlier-suppression iteration',iter,' of',nter
4714 WRITE(1,*) '=========================================='
4715 WRITE(1,*) ' '
4716 imeas=0
4717 END IF
4718
4719 ! ----- second loop ------------------------------------------------
4720 ! accumulate normal equations for local fit and determine solution
4721 DO i=1,nalc
4722 blvec(i)=0.0_mpd ! reset vector
4723 END DO
4724 DO i=1,(nalc*nalc+nalc)/2 ! GF: FIXME - not really, local parameter number...
4725 clmat(i)=0.0_mpd ! (p)reset matrix
4726 END DO
4727 ndown=0
4728 nweig=0
4729 cndl10=0.
4730 DO ieq=1,neq! loop over measurements
4731 ja=localequations(1,ioffq+ieq)
4732 jb=localequations(2,ioffq+ieq)
4733 rmeas=real(readbufferdatad(ja),mpd) ! data
4734 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4735 wght =1.0_mpd/rerr**2 ! weight from error
4736 nweig=nweig+1
4737 resid=rmeas-localcorrections(ioffq+ieq) ! subtract previous fit
4738 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4739 IF(iter <= 3) THEN
4740 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4741 wght=wght*chuber*rerr/abs(resid)
4742 ndown=ndown+1
4743 END IF
4744 ELSE ! Cauchy
4745 wght=wght/(1.0+(resid/rerr/cauchy)**2)
4746 END IF
4747 END IF
4748
4749 IF(lprnt.AND.iter /= 1.AND.nter /= 1) THEN
4750 chast=' '
4751 IF(abs(resid) > chuber*rerr) chast='* '
4752 IF(abs(resid) > 3.0*rerr) chast='** '
4753 IF(abs(resid) > 6.0*rerr) chast='***'
4754 IF(imeas == 0) WRITE(1,*) 'Second loop: accumulate'
4755 IF(imeas == 0) WRITE(1,103)
4756 imeas=imeas+1
4757 down=1.0/sqrt(wght)
4758 r1=resid/rerr
4759 r2=resid/down
4760 WRITE(1,104) imeas,rmeas,resid,rerr,r1,chast,r2
4761 END IF
4762103 FORMAT(' index corrvalue residuum sigma', &
4763 ' nresid cnresid')
4764104 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4765
4766 DO j=1,jb-ja-1 ! normal equations, local parameter loop
4767 ij=readbufferdatai(ja+j) ! local parameter index J
4768 blvec(ij)=blvec(ij)+wght*rmeas*real(readbufferdatad(ja+j),mpd)
4769 DO k=1,j
4770 ik=readbufferdatai(ja+k) ! local parameter index K
4771 jk=(ij*ij-ij)/2+ik ! index in symmetric matrix
4772 clmat(jk)=clmat(jk) & ! force double precision
4773 +wght*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)
4774 ! check for band matrix substructure
4775 IF (iter == 1) THEN
4776 id=iabs(ij-ik)+1
4777 im=min(ij,ik) ! upper/left border
4778 ibandh(id)=max(ibandh(id),im)
4779 im=min(nalc+1-ij,nalc+1-ik) ! lower/rght border (mirrored)
4780 ibandh(nalc+id)=max(ibandh(nalc+id),im)
4781 END IF
4782 END DO
4783 END DO
4784 END DO
4785 ! for non trivial fits check for bordered band matrix structure
4786 IF (iter == 1.AND.nalc > 5.AND.lfitbb > 0) THEN
4787 kx=-1
4788 kbdrx=0
4789 icmn=int(nalc,mpl)**3 ! cost (*6) should improve by at least factor 2
4790 ! upper/left border ?
4791 kbdr=0
4792 DO k=nalc,2,-1
4793 kbnd=k-2
4794 kbdr=max(kbdr,ibandh(k))
4795 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4796 IF (icost < icmn) THEN
4797 icmn=icost
4798 kx=k
4799 kbdrx=kbdr
4800 mside=1
4801 END IF
4802 END DO
4803 IF (kx < 0) THEN
4804 ! lower/right border instead?
4805 kbdr=0
4806 DO k=nalc,2,-1
4807 kbnd=k-2
4808 kbdr=max(kbdr,ibandh(k+nalc))
4809 icost=6*int(nalc-kbdr,mpl)*int(kbnd+kbdr+1,mpl)**2+2*int(kbdr,mpl)**3
4810 IF (icost < icmn) THEN
4811 icmn=icost
4812 kx=k
4813 kbdrx=kbdr
4814 mside=2
4815 END IF
4816 END DO
4817 END IF
4818 IF (kx > 0) THEN
4819 mbnd=kx-2
4820 mbdr=kbdrx
4821 END IF
4822 END IF
4823
4824 IF (mbnd >= 0) THEN
4825 ! fast solution for border banded matrix (inverse for ICALCM>0)
4826 IF (nloopn == 1) THEN
4827 nbndr(mside)=nbndr(mside)+1
4828 nbdrx=max(nbdrx,mbdr)
4829 nbndx=max(nbndx,mbnd)
4830 END IF
4831
4832 inv=0
4833 IF (nloopn <= lfitnp.AND.iter == 1) inv=1 ! band part of inverse (for pulls)
4834 IF (icalcm == 1.OR.lprnt) inv=2 ! complete inverse
4835 IF (mside == 1) THEN
4836 CALL sqmibb(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4837 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
4838 ELSE
4839 CALL sqmibb2(clmat,blvec,nalc,mbdr,mbnd,inv,nrank, &
4840 vbnd,vbdr,aux,vbk,vzru,scdiag,scflag,evdmin,evdmax)
4841 ENDIF
4842 ! log10(condition of band part)
4843 IF (evdmin > 0.0_mpl) cndl10=log10(real(evdmax/evdmin,mps))
4844 IF (lhist.AND.nloopn == 1) CALL hmpent(16,cndl10)
4845 ELSE
4846 ! full inversion and solution
4847 inv=2
4848 CALL sqminv(clmat,blvec,nalc,nrank,scdiag,scflag)
4849 END IF
4850 ! check for NaNs
4851 nan=0
4852 DO k=1, nalc
4853 IF ((.NOT.(blvec(k) <= 0.0_mpd)).AND. (.NOT.(blvec(k) > 0.0_mpd))) nan=nan+1
4854 END DO
4855
4856 IF(lprnt) THEN
4857 WRITE(1,*) ' '
4858 WRITE(1,*) 'Parameter determination:',nalc,' parameters,', ' rank=',nrank
4859 WRITE(1,*) '-----------------------'
4860 IF(ndown /= 0) WRITE(1,*) ' ',ndown,' data down-weighted'
4861 WRITE(1,*) ' '
4862 END IF
4863
4864 ! ----- third loop -------------------------------------------------
4865 ! calculate single residuals remaining after local fit and chi^2
4866
4867 summ=0.0_mpd
4868 suwt=0.0
4869 imeas=0
4870 DO ieq=1,neq! loop over measurements
4871 ja=localequations(1,ioffq+ieq)
4872 jb=localequations(2,ioffq+ieq)
4873 ist=localequations(3,ioffq+ieq)
4874 rmeas=real(readbufferdatad(ja),mpd) ! data (global contrib. subtracted)
4875 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
4876 wght =1.0_mpd/rerr**2 ! weight from error
4877 rmloc=0.0 ! local fit result reset
4878 DO j=1,jb-ja-1 ! local parameter loop
4879 ij=readbufferdatai(ja+j)
4880 rmloc=rmloc+real(readbufferdatad(ja+j),mpd)*blvec(ij) ! local fit result
4881 END DO
4882 localcorrections(ioffq+ieq)=rmloc ! save local fit result
4883 rmeas=rmeas-rmloc ! reduced to residual
4884
4885 ! calculate pulls? (needs covariance matrix)
4886 IF(iter == 1.AND.inv > 0.AND.nloopn <= lfitnp) THEN
4887 dvar=0.0_mpd
4888 DO j=1,jb-ja-1
4889 ij=readbufferdatai(ja+j)
4890 jk=(ij*ij-ij)/2 ! index in symmetric matrix, row offset
4891 ! off diagonal (symmetric)
4892 DO k=1,j-1
4893 ik=readbufferdatai(ja+k)
4894 dvar=dvar+clmat(jk+ik)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+k),mpd)*2.0_mpd
4895 END DO
4896 ! diagonal
4897 dvar=dvar+clmat(jk+ij)*real(readbufferdatad(ja+j),mpd)*real(readbufferdatad(ja+j),mpd)
4898 END DO
4899 ! some variance left to define a pull?
4900 IF (0.999999_mpd/wght > dvar) THEN
4901 pull=rmeas/sqrt(1.0_mpd/wght-dvar)
4902 IF (lhist) THEN
4903 IF (jb < ist) THEN
4904 CALL hmpent(13,real(pull,mps)) ! histogram pull
4905 CALL gmpms(5,rec,real(pull,mps))
4906 ELSE
4907 CALL hmpent(14,real(pull,mps)) ! histogram pull
4908 END IF
4909 END IF
4910 ! monitoring
4911 IF (imonit /= 0) THEN
4912 IF (jb < ist) THEN
4913 ij=readbufferdatai(jb+1) ! group by first global label
4914 if (imonmd == 0) THEN
4915 irbin=min(measbins,max(1,int(pull*rerr/measres(ij)/measbinsize+0.5*real(measbins,mpd))))
4916 ELSE
4917 irbin=min(measbins,max(1,int(pull/measbinsize+0.5*real(measbins,mpd))))
4918 ENDIF
4919 irbin=irbin+measbins*(measindex(ij)-1+nummeas*iproc)
4920 meashists(irbin)=meashists(irbin)+1
4921 ENDIF
4922 ENDIF
4923 END IF
4924 END IF
4925
4926 IF(iter == 1.AND.jb < ist.AND.lhist) &
4927 CALL gmpms(4,rec,real(rmeas/rerr,mps)) ! residual (with global deriv.)
4928
4929 dchi2=wght*rmeas*rmeas
4930 ! DCHIT=DCHI2
4931 resid=rmeas
4932 IF(nloopn /= 1.AND.iter /= 1.AND.lhuber /= 0) THEN
4933 IF(iter <= 3) THEN
4934 IF(abs(resid) > chuber*rerr) THEN ! down-weighting
4935 wght=wght*chuber*rerr/abs(resid)
4936 dchi2=2.0*chuber*(abs(resid)/rerr-0.5*chuber)
4937 END IF
4938 ELSE
4939 wght=wght/(1.0_mpd+(resid/rerr/cauchy)**2)
4940 dchi2=log(1.0_mpd+(resid/rerr/cauchy)**2)*cauchy**2
4941 END IF
4942 END IF
4943
4944 down=1.0/sqrt(wght)
4945
4946 ! SUWT=SUWT+DCHI2/DCHIT
4947 suwt=suwt+rerr/down
4948 IF(lprnt) THEN
4949 chast=' '
4950 IF(abs(resid) > chuber*rerr) chast='* '
4951 IF(abs(resid) > 3.0*rerr) chast='** '
4952 IF(abs(resid) > 6.0*rerr) chast='***'
4953 IF(imeas == 0) WRITE(1,*) 'Third loop: single residuals'
4954 IF(imeas == 0) WRITE(1,105)
4955 imeas=imeas+1
4956 r1=resid/rerr
4957 r2=resid/down
4958 IF(resid < 0.0) r1=-r1
4959 IF(resid < 0.0) r2=-r2
4960 WRITE(1,106) imeas,readbufferdatad(ja),rmeas,rerr,r1,chast,r2
4961 END IF
4962105 FORMAT(' index corrvalue residuum sigma', &
4963 ' nresid cnresid')
4964106 FORMAT(i6,2x,2g12.4,' +-',g12.4,f7.2,1x,a3,f8.2)
4965
4966 IF(iter == nter) THEN
4967 readbufferdatad(ja)=real(rmeas,mpr8) ! store remaining residual
4968 resmax=max(resmax,abs(rmeas)/rerr)
4969 END IF
4970
4971 IF(iter == 1.AND.lhist) THEN
4972 IF (jb < ist) THEN
4973 CALL hmpent( 3,real(rmeas/rerr,mps)) ! histogram norm residual
4974 ELSE
4975 CALL hmpent(12,real(rmeas/rerr,mps)) ! histogram norm residual
4976 END IF
4977 END IF
4978 summ=summ+dchi2 ! accumulate chi-square sum
4979 END DO
4980
4981 ndf=neq-nrank
4982 resing=(real(nweig,mps)-real(suwt,mps))/real(nweig,mps)
4983 IF (lhist) THEN
4984 IF(iter == 1) CALL hmpent( 5,real(ndf,mps)) ! histogram Ndf
4985 IF(iter == 1) CALL hmpent(11,real(nalc,mps)) ! histogram Nlocal
4986 IF(nloopn == 2.AND.iter == nter) CALL hmpent(6,resing)
4987 END IF
4988 IF(lprnt) THEN
4989 WRITE(1,*) ' '
4990 WRITE(1,*) 'Chi^2=',summ,' at',ndf,' degrees of freedom: ', &
4991 '3-sigma limit is',chindl(3,ndf)*real(ndf,mps)
4992 WRITE(1,*) suwt,' is sum of factors, compared to',nweig, &
4993 ' Downweight fraction:',resing
4994 END IF
4995 IF(nan > 0) THEN
4996 nrej(1)=nrej(1)+1 ! count cases
4997 IF (nrec3 == huge(nrec3)) nrec3=nrc
4998 IF(lprnt) THEN
4999 WRITE(1,*) ' NaNs ', nalc, nrank, nan
5000 WRITE(1,*) ' ---> rejected!'
5001 END IF
5002 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-1 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5003 GO TO 90
5004 END IF
5005 IF(nrank /= nalc) THEN
5006 nrej(2)=nrej(2)+1 ! count cases
5007 IF (nrec3 == huge(nrec3)) nrec3=nrc
5008 IF(lprnt) THEN
5009 WRITE(1,*) ' rank deficit', nalc, nrank
5010 WRITE(1,*) ' ---> rejected!'
5011 END IF
5012 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-2 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5013 GO TO 90
5014 END IF
5015 IF(cndl10 > cndlmx) THEN
5016 nrej(3)=nrej(3)+1 ! count cases
5017 IF (nrec3 == huge(nrec3)) nrec3=nrc
5018 IF(lprnt) THEN
5019 WRITE(1,*) ' too large condition(band part) ', nalc, nrank, cndl10
5020 WRITE(1,*) ' ---> rejected!'
5021 END IF
5022 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-3 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5023 GO TO 90
5024 END IF
5025 IF(ndf <= 0) THEN
5026 nrej(4)=nrej(4)+1 ! count cases
5027 IF(lprnt) THEN
5028 WRITE(1,*) ' Ndf<=0', nalc, nrank, ndf
5029 WRITE(1,*) ' ---> rejected!'
5030 END IF
5031 IF (mdebug < 0.AND.nloopn == 1) print *, ' bad local fit-4 ', kfl,jrc,nrc,mside,neq,nalc,nrank,nan,cndl10
5032 GO TO 90
5033 END IF
5034
5035 chndf=real(summ/real(ndf,mpd),mps)
5036
5037 IF(iter == 1.AND.lhist) CALL hmpent(4,chndf) ! histogram chi^2/Ndf
5038 END DO ! outlier iteration loop
5039
5040 ! ----- reject eventually ------------------------------------------
5041
5042 IF(newite.AND.iterat == 2) THEN ! find record with largest Chi^2/Ndf
5043 IF(nrecp2 < 0.AND.chndf > writebufferdata(2,iproc+1)) THEN
5044 writebufferdata(2,iproc+1)=chndf
5045 writebufferinfo(8,iproc+1)=jrc
5046 writebufferinfo(9,iproc+1)=kfl
5047 END IF
5048 END IF
5049
5050 chichi=chindl(3,ndf)*real(ndf,mps)
5051 ! GF IF(SUMM.GT.50.0*CHICHI) THEN ! huge
5052 ! CHK CHICUT<0: NO cut (1st iteration)
5053 IF(chicut >= 0.0) THEN
5054 IF(summ > chhuge*chichi) THEN ! huge
5055 nrej(5)=nrej(5)+1 ! count cases with huge chi^2
5056 IF(lprnt) THEN
5057 WRITE(1,*) ' ---> rejected!'
5058 END IF
5059 GO TO 90
5060 END IF
5061
5062 IF(chicut > 0.0) THEN
5063 chlimt=chicut*chichi
5064 ! WRITE(*,*) 'chi^2 ',SUMM,CHLIMT,CHICUT,CHINDL(3,NDF),NDF
5065 IF(summ > chlimt) THEN
5066 IF(lprnt) THEN
5067 WRITE(1,*) ' ---> rejected!'
5068 END IF
5069 ! add to FVALUE
5070 dchi2=chlimt ! total contribution limit
5071 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
5072 nrej(6)=nrej(6)+1 ! count cases with large chi^2
5073 GO TO 90
5074 END IF
5075 END IF
5076 END IF
5077
5078 IF(lhuber > 1.AND.dwcut /= 0.0.AND.resing > dwcut) THEN
5079 ! add to FVALUE
5080 dchi2=summ ! total contribution
5081 CALL addsums(iproc+1, dchi2, ndf, dw1) ! add total contribution
5082 nrej(6)=nrej(6)+1 ! count cases with large chi^2
5083 ! WRITE(*,*) 'Downweight fraction cut ',RESING,DWCUT,SUMM
5084 IF(lprnt) THEN
5085 WRITE(1,*) ' ---> rejected!'
5086 END IF
5087 GO TO 90
5088 END IF
5089
5090 IF(newite.AND.iterat == 2) THEN ! find record with largest residual
5091 IF(nrecpr < 0.AND.resmax > writebufferdata(1,iproc+1)) THEN
5092 writebufferdata(1,iproc+1)=real(resmax,mps)
5093 writebufferinfo(6,iproc+1)=jrc
5094 writebufferinfo(7,iproc+1)=kfl
5095 END IF
5096 END IF
5097 ! 'track quality' per binary file: accepted records
5098 naccf(kfl)=naccf(kfl)+1
5099 ndff(kfl) =ndff(kfl) +ndf
5100 chi2f(kfl)=chi2f(kfl)+chndf
5101
5102 ! ----- fourth loop ------------------------------------------------
5103 ! update of global matrix and vector according to the "Millepede"
5104 ! principle, from the global/local information
5105
5106 summ=0.0_mpd
5107 DO ieq=1,neq! loop over measurements
5108 ja=localequations(1,ioffq+ieq)
5109 jb=localequations(2,ioffq+ieq)
5110 ist=localequations(3,ioffq+ieq)
5111 rmeas=real(readbufferdatad(ja),mpd) ! data residual
5112 rerr =real(readbufferdatad(jb),mpd) ! ... and the error
5113 wght =1.0_mpd/rerr**2 ! weight from measurement error
5114 dchi2=wght*rmeas*rmeas ! least-square contribution
5115
5116 IF(nloopn /= 1.AND.lhuber /= 0) THEN ! check residual
5117 resid=abs(rmeas)
5118 IF(resid > chuber*rerr) THEN
5119 wght=wght*chuber*rerr/resid ! down-weighting
5120 dchi2=2.0*chuber*(resid/rerr-0.5*chuber) ! modified contribution
5121 END IF
5122 END IF
5123 ! sum up
5124 summ=summ+dchi2
5125
5126 ! global-global matrix contribution: add directly to gg-matrix
5127
5128 DO j=1,ist-jb
5129 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5130 IF (readbufferdatad(jb+j) == 0.0_mpd) cycle ! skip zero global derivatives
5131 IF(ivgbj > 0) THEN
5132 globalvector(ioffb+ivgbj)=globalvector(ioffb+ivgbj) &
5133 +dw1*wght*rmeas*real(readbufferdatad(jb+j),mpd) ! vector !!! reverse
5134 globalcounter(ioffb+ivgbj)=globalcounter(ioffb+ivgbj)+1
5135 IF(icalcm == 1) THEN
5136 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5137 DO k=1,j
5139 IF(ivgbk > 0) THEN
5140 ike=backindexusage(ioffe+ivgbk) ! get index of index, non-zero
5141 ia=max(ije,ike) ! larger
5142 ib=min(ije,ike) ! smaller
5143 ij=ib+(ia*ia-ia)/2
5144 writebufferupdates(ioffd+ij)=writebufferupdates(ioffd+ij) &
5145 -dw1*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(jb+k),mpd)
5146 END IF
5147 END DO
5148 END IF
5149 END IF
5150 END DO
5151
5152 ! normal equations - rectangular matrix for global/local pars
5153 ! global-local matrix contribution: accumulate rectangular matrix
5154 IF (icalcm /= 1) cycle
5155 DO j=1,ist-jb
5156 ivgbj=globalparlabelindex(2,readbufferdatai(jb+j)) ! -> index of variable global parameter
5157 IF(ivgbj > 0) THEN
5158 ije=backindexusage(ioffe+ivgbj) ! get index of index, non-zero
5159 DO k=1,jb-ja-1
5160 ik=readbufferdatai(ja+k) ! local index
5161 jk=ik+(ije-1)*nalc ! matrix index
5163 dw2*wght*real(readbufferdatad(jb+j),mpd)*real(readbufferdatad(ja+k),mpd)
5165 END DO
5166 END IF
5167 END DO
5168 END DO
5169 ! add to total objective function
5170 CALL addsums(iproc+1, summ, ndf, dw1)
5171
5172 ! ----- final matrix update ----------------------------------------
5173 ! update global matrices and vectors
5174 IF(icalcm /= 1) GO TO 90 ! matrix update
5175 ! (inverse local matrix) * (rectang. matrix) -> CORM
5176 ! T
5177 ! resulting symmetrix matrix = G * Gamma^{-1} * G
5178
5179 ! check sparsity of localGlobalMatrix (with par. groups)
5180 isize=nalc+nalg+1 ! row/clolumn offsets
5181 ! check rows
5182 k=0 ! offset
5183 DO i=1, nalg
5184 localglobalstructure(i)=isize
5185 DO j=1, nalc
5186 IF (localglobalmap(k+j) > 0) THEN
5187 localglobalstructure(isize+1)=j ! column
5188 localglobalstructure(isize+2)=k+j ! index
5189 isize=isize+2
5190 ENDIF
5191 END DO
5192 k=k+nalc
5193 END DO
5194 ! <50% non-zero elements?
5195 IF (isize-localglobalstructure(1) < nalc*nalg) THEN
5196 ! check columns (too)
5197 DO j=1, nalc
5198 localglobalstructure(nalg+j)=isize
5199 k=0 ! offset
5200 DO i=1, nalg
5201 IF (localglobalmap(k+j) > 0) THEN
5202 localglobalstructure(isize+1)=i ! row
5203 localglobalstructure(isize+2)=k+j ! index
5204 isize=isize+2
5205 ENDIF
5206 k=k+nalc
5207 END DO
5208 END DO
5209 localglobalstructure(nalg+nalc+1)=isize
5211 ELSE
5212 CALL dbavat(clmat,localglobalmatrix,writebufferupdates(ioffd+1),nalc,nalg,1)
5213 END IF
5214 ! (rectang. matrix) * (local param vector) -> CORV
5215 ! resulting vector = G * q (q = local parameter)
5216 ! CALL DBGAX(DQ(IGLMA/2+1),BLVEC,DQ(ICORV/2+1),NALG,NALC) ! not done
5217 ! the vector update is not done, because after local fit it is zero!
5218
5219 ! update cache status
5220 writebufferinfo(1,iproc+1)=writebufferinfo(1,iproc+1)+1
5221 writebufferinfo(2,iproc+1)=writebufferinfo(2,iproc+1)+ngg
5222 writebufferinfo(3,iproc+1)=writebufferinfo(3,iproc+1)+ngrp+3
5223 ! check free space
5224 nfred=writebufferheader(-1)-writebufferinfo(2,iproc+1)-writebufferheader(-2)
5226 IF (nfred < 0.OR.nfrei < 0) THEN ! need to flush
5227 nb=writebufferinfo(1,iproc+1)
5228 joffd=writebufferheader(-1)*iproc ! offset data
5229 joffi=writebufferheader(1)*iproc+3 ! offset indices
5230 used=real(writebufferinfo(2,iproc+1),mps)/real(writebufferheader(-1),mps)
5231 writebufferinfo(4,iproc+1)=writebufferinfo(4,iproc+1) +nint(1000.0*used,mpi)
5232 used=real(writebufferinfo(3,iproc+1),mps)/real(writebufferheader(1),mps)
5233 writebufferinfo(5,iproc+1)=writebufferinfo(5,iproc+1) +nint(1000.0*used,mpi)
5234 !$OMP CRITICAL
5237
5238 DO ib=1,nb
5239 nalg=writebufferindices(joffi-1)
5240 il=1 ! row in update matrix
5241 DO in=1,writebufferindices(joffi)
5242 i=writebufferindices(joffi+in)
5243 j=writebufferindices(joffi+1) ! 1. group
5244 iprc=ijprec(i,j) ! group pair precision
5245 jl=1 ! col in update matrix
5246 ! start (rows) for continous groups
5247 j1=j
5248 jl1=jl
5249 ! other groups for row
5250 DO jn=2,in
5252 jnx=writebufferindices(joffi+jn) ! next group
5253 iprcnx=ijprec(i,jnx) ! group pair precision
5254 ! end of continous groups?
5255 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5256 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5257 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5258 ! restart continous groups
5259 j1=jnx ! new 1. column
5260 jl1=jl
5261 iprc=iprcnx
5262 END IF
5263 j=jnx ! last group
5264 END DO
5265 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5266 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5268 END DO
5269 joffd=joffd+(il*il-il)/2
5270 joffi=joffi+writebufferindices(joffi)+3
5271 END DO
5272 !$OMP END CRITICAL
5273 ! reset counter, pointers
5274 DO k=1,3
5275 writebufferinfo(k,iproc+1)=0
5276 END DO
5277 END IF
5278
527990 IF(lprnt) THEN
5280 WRITE(1,*) ' '
5281 WRITE(1,*) '------------------ End of printout for record',nrc
5282 WRITE(1,*) ' '
5283 END IF
5284
5285 DO i=1,nalg ! reset global index array
5286 iext=globalindexusage(ioffc+i)
5287 backindexusage(ioffe+iext)=0
5288 END DO
5289
5290 END DO
5291 !$OMP END PARALLEL DO
5292
5293 IF (icalcm == 1) THEN
5294 ! flush remaining matrices
5295 DO k=1,mthrd ! update statistics
5297 used=real(writebufferinfo(2,k),mps)/real(writebufferheader(-1),mps)
5298 writebufferinfo(4,k)=writebufferinfo(4,k)+nint(1000.0*used,mpi)
5301 writebufferinfo(4,k)=0
5303 used=real(writebufferinfo(3,k),mps)/real(writebufferheader(1),mps)
5304 writebufferinfo(5,k)=writebufferinfo(5,k)+nint(1000.0*used,mpi)
5307 writebufferinfo(5,k)=0
5308 END DO
5309
5310 !$OMP PARALLEL &
5311 !$OMP DEFAULT(PRIVATE) &
5312 !$OMP SHARED(writeBufferHeader,writeBufferInfo,writeBufferIndices,writeBufferUpdates,MTHRD) &
5313 !$OMP SHARED(globalAllParToGroup,globalAllIndexGroups,nspc)
5314 iproc=0
5315 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5316 DO jproc=0,mthrd-1
5317 nb=writebufferinfo(1,jproc+1)
5318 ! print *, ' flush end ', JPROC, NRC, NB
5319 joffd=writebufferheader(-1)*jproc ! offset data
5320 joffi=writebufferheader(1)*jproc+3 ! offset indices
5321 DO ib=1,nb
5322 ! print *, ' buf end ', JPROC,IB,writeBufferIndices(JOFFI-2),writeBufferIndices(JOFFI)
5323 nalg=writebufferindices(joffi-1)
5324 il=1 ! row in update matrix
5325 DO in=1,writebufferindices(joffi)
5326 i=writebufferindices(joffi+in)
5327 !$ IF (MOD(I,MTHRD).EQ.IPROC) THEN
5328 j=writebufferindices(joffi+1) ! 1. group
5329 iprc=ijprec(i,j) ! group pair precision
5330 jl=1 ! col in update matrix
5331 ! start (rows) for continous groups
5332 j1=j
5333 jl1=jl
5334 ! other groups for row
5335 DO jn=2,in
5337 jnx=writebufferindices(joffi+jn) ! next group
5338 iprcnx=ijprec(i,jnx) ! group pair precision
5339 ! end of continous groups?
5340 IF (.NOT.((jnx == j+1).AND.(iprc == iprcnx))) THEN
5341 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! matrix update
5342 !print *, ' update ', ib,i,j1,j,il,jl1,0,iprc,jnx,iprcnx
5343 ! restart continous groups
5344 j1=jnx ! new 1. column
5345 jl1=jl
5346 iprc=iprcnx
5347 END IF
5348 j=jnx ! last group
5349 END DO
5350 CALL mgupdt(i,j1,j,il,jl1,nalg,writebufferupdates(joffd+1)) ! final matrix update
5351 !print *, '.update ', ib, i,j1,j,il,jl1,1,iprc
5352 !$ END IF
5354 END DO
5355 joffd=joffd+(il*il-il)/2
5356 joffi=joffi+writebufferindices(joffi)+3
5357 END DO
5358 END DO
5359 !$OMP END PARALLEL
5360 END IF
5361
5362 IF(newite.AND.iterat == 2) THEN ! get worst records (for printrecord -1 -1)
5363 IF (nrecpr < 0) THEN
5364 DO k=1,mthrd
5365 IF (writebufferdata(1,k) > value1) THEN
5368 END IF
5369 END DO
5370 END IF
5371 IF (nrecp2 < 0) THEN
5372 DO k=1,mthrd
5373 IF (writebufferdata(2,k) > value2) THEN
5376 END IF
5377 END DO
5378 END IF
5379 END IF
5380
5381END SUBROUTINE loopbf
5382
5383!***********************************************************************
5384
5387SUBROUTINE prtrej(lun)
5388 USE mpmod
5389
5390 IMPLICIT NONE
5391 INTEGER(mpi), INTENT(IN) :: lun
5392
5393 IF (nrejec(1)>0) WRITE(lun,*) nrejec(1), ' (local solution contains NaNs)'
5394 IF (nrejec(2)>0) WRITE(lun,*) nrejec(2), ' (local matrix with rank deficit)'
5395 IF (nrejec(3)>0) WRITE(lun,*) nrejec(3), ' (local matrix with ill condition)'
5396 IF (nrejec(4)>0) WRITE(lun,*) nrejec(4), ' (local fit with Ndf=0)'
5397 IF (nrejec(5)>0) WRITE(lun,*) nrejec(5), ' (local fit with huge Chi2(Ndf))'
5398 IF (nrejec(6)>0) WRITE(lun,*) nrejec(6), ' (local fit with large Chi2(Ndf))'
5399
5400END SUBROUTINE prtrej
5401
5402!***********************************************************************
5403
5416SUBROUTINE prtglo
5417 USE mpmod
5418
5419 IMPLICIT NONE
5420 REAL(mps):: dpa
5421 REAL(mps):: err
5422 REAL(mps):: gcor
5423 INTEGER(mpi) :: i
5424 INTEGER(mpi) :: icom
5425 INTEGER(mpl) :: icount
5426 INTEGER(mpi) :: ie
5427 INTEGER(mpi) :: iev
5428 INTEGER(mpi) :: ij
5429 INTEGER(mpi) :: imin
5430 INTEGER(mpi) :: iprlim
5431 INTEGER(mpi) :: isub
5432 INTEGER(mpi) :: itgbi
5433 INTEGER(mpi) :: itgbl
5434 INTEGER(mpi) :: ivgbi
5435 INTEGER(mpi) :: j
5436 INTEGER(mpi) :: label
5437 INTEGER(mpi) :: lup
5438 REAL(mps):: par
5439 LOGICAL :: lowstat
5440
5441 REAL(mpd):: diag
5442 REAL(mpd)::gmati
5443 REAL(mpd)::gcor2
5444 INTEGER(mpi) :: labele(3)
5445 REAL(mps):: compnt(3)
5446 SAVE
5447 ! ...
5448
5449 lup=09
5450 CALL mvopen(lup,'millepede.res')
5451
5452 WRITE(*,*) ' '
5453 WRITE(*,*) ' Result of fit for global parameters'
5454 WRITE(*,*) ' ==================================='
5455 WRITE(*,*) ' '
5456
5457 WRITE(*,101)
5458
5459 WRITE(lup,*) 'Parameter ! first 3 elements per line are', &
5460 ' significant (if used as input)'
5461
5462
5463 iprlim=10
5464 DO itgbi=1,ntgb ! all parameter variables
5465 itgbl=globalparlabelindex(1,itgbi)
5466 ivgbi=globalparlabelindex(2,itgbi)
5467 icom=globalparcomments(itgbi) ! comment
5468 IF (icom > 0) WRITE(lup,113) listcomments(icom)%text
5469 par=real(globalparameter(itgbi),mps) ! initial value
5470 icount=0 ! counts
5471 lowstat = .false.
5472 IF(ivgbi > 0) THEN
5473 icount=globalcounter(ivgbi) ! used in last iteration
5474 lowstat = (icount < mreqena) ! too few accepted entries
5475 dpa=real(globalparameter(itgbi)-globalparstart(itgbi),mps) ! difference
5476 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5477 gmati=globalmatd(globalrowoffsets(ivgbi)+ivgbi)
5478 err=sqrt(abs(real(gmati,mps)))
5479 IF(gmati < 0.0_mpd) err=-err
5480 diag=workspacediag(ivgbi)
5481 gcor=-1.0
5482 IF(gmati*diag > 0.0_mpd) THEN ! global correlation
5483 gcor2=1.0_mpd-1.0_mpd/(gmati*diag)
5484 IF(gcor2 >= 0.0_mpd.AND.gcor2 <= 1.0_mpd) gcor=real(sqrt(gcor2),mps)
5485 END IF
5486 END IF
5487 END IF
5488 IF(ipcntr > 1) icount=globalparlabelcounter(itgbi) ! from binary files
5489 IF(lowstat) icount=-(icount+1) ! flag 'lowstat' with icount < 0
5490 IF(ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
5491 IF(itgbi <= iprlim) THEN
5492 IF(ivgbi <= 0) THEN
5493 WRITE(* ,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5494 ELSE
5495 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5496 IF (igcorr == 0) THEN
5497 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5498 ELSE
5499 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5500 END IF
5501 ELSE
5502 WRITE(*,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5503 END IF
5504 END IF
5505 ELSE IF(itgbi == iprlim+1) THEN
5506 WRITE(* ,*) '... (further printout suppressed, but see log file)'
5507 END IF
5508
5509 ! file output
5510 IF(ivgbi <= 0) THEN
5511 IF (ipcntr /= 0) THEN
5512 WRITE(lup,110) itgbl,par,real(globalparpresigma(itgbi),mps),icount
5513 ELSE
5514 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps)
5515 END IF
5516 ELSE
5517 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
5518 IF (ipcntr /= 0) THEN
5519 WRITE(lup,112) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,icount
5520 ELSE IF (igcorr /= 0) THEN
5521 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err,gcor
5522 ELSE
5523 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,err
5524 END IF
5525 ELSE
5526 IF (ipcntr /= 0) THEN
5527 WRITE(lup,111) itgbl,par,real(globalparpresigma(itgbi),mps),dpa,icount
5528 ELSE
5529 WRITE(lup,102) itgbl,par,real(globalparpresigma(itgbi),mps),dpa
5530 END IF
5531 END IF
5532 END IF
5533 END DO
5534 rewind lup
5535 CLOSE(unit=lup)
5536
5537 IF(metsol == 2) THEN ! diagonalisation: write eigenvectors
5538 CALL mvopen(lup,'millepede.eve')
5539 imin=1
5540 DO i=nagb,1,-1
5541 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
5542 imin=i ! index of smallest pos. eigenvalue
5543 EXIT
5544 ENDIF
5545 END DO
5546 iev=0
5547
5548 DO isub=0,min(15,imin-1)
5549 IF(isub < 10) THEN
5550 i=imin-isub
5551 ELSE
5552 i=isub-9
5553 END IF
5554
5555 ! DO I=IMIN,MAX(1,IMIN-9),-1 ! backward loop, up to 10 vectors
5556 WRITE(*,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5557 WRITE(lup,*) 'Eigenvector ',i,' with eigenvalue',workspaceeigenvalues(i)
5558 DO j=1,nagb
5559 ij=j+(i-1)*nagb ! index with eigenvector array
5560 IF(j <= nvgb) THEN
5561 itgbi=globalparvartototal(j)
5562 label=globalparlabelindex(1,itgbi)
5563 ELSE
5564 label=nvgb-j ! label negative for constraints
5565 END IF
5566 iev=iev+1
5567 labele(iev)=label
5568 compnt(iev)=real(workspaceeigenvectors(ij),mps) ! component
5569 IF(iev == 3) THEN
5570 WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5571 iev=0
5572 END IF
5573 END DO
5574 IF(iev /= 0) WRITE(lup,103) (labele(ie),compnt(ie),ie=1,iev)
5575 iev=0
5576 WRITE(lup,*) ' '
5577 END DO
5578 CLOSE(unit=lup)
5579
5580 END IF
5581
5582101 FORMAT(1x,' label parameter presigma differ', &
5583 ' error'/ 1x,'-----------',4x,4('-------------'))
5584102 FORMAT(i10,2x,4g14.5,f8.3)
5585103 FORMAT(3(i11,f11.7,2x))
5586110 FORMAT(i10,2x,2g14.5,28x,i12)
5587111 FORMAT(i10,2x,3g14.5,14x,i12)
5588112 FORMAT(i10,2x,4g14.5,i12)
5589113 FORMAT('!',a)
5590END SUBROUTINE prtglo ! print final log file
5591
5592!***********************************************************************
5593
5603SUBROUTINE prtstat
5604 USE mpmod
5605 USE mpdalc
5606
5607 IMPLICIT NONE
5608 REAL(mps):: par
5609 REAL(mps):: presig
5610 INTEGER(mpi) :: icom
5611 INTEGER(mpl) :: icount
5612 INTEGER(mpi) :: ifrst
5613 INTEGER(mpi) :: ilast
5614 INTEGER(mpi) :: inext
5615 INTEGER(mpi) :: itgbi
5616 INTEGER(mpi) :: itgbl
5617 INTEGER(mpi) :: itpgrp
5618 INTEGER(mpi) :: ivgbi
5619 INTEGER(mpi) :: lup
5620 INTEGER(mpi) :: icgrp
5621 INTEGER(mpi) :: ipgrp
5622 INTEGER(mpi) :: j
5623 INTEGER(mpi) :: jpgrp
5624 INTEGER(mpi) :: k
5625 INTEGER(mpi) :: label1
5626 INTEGER(mpi) :: label2
5627 INTEGER(mpi) :: ncon
5628 INTEGER(mpi) :: npair
5629 INTEGER(mpi) :: nstep
5630 CHARACTER :: c1
5631
5632 INTEGER(mpl):: length
5633
5634 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
5635
5636 INTERFACE ! needed for assumed-shape dummy arguments
5637 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
5638 USE mpdef
5639 INTEGER(mpi), INTENT(IN) :: ipgrp
5640 INTEGER(mpi), INTENT(OUT) :: npair
5641 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
5642 END SUBROUTINE ggbmap
5643 END INTERFACE
5644
5645 SAVE
5646 ! ...
5647
5648 lup=09
5649 CALL mvopen(lup,'millepede.res')
5650 WRITE(lup,*) '*** Results of checking input only, no solution performed ***'
5651 WRITE(lup,*) '! === global parameters ==='
5652 WRITE(lup,*) '! fixed-1: by pre-sigma, -2: by entries cut, -3: by iterated entries cut'
5653 IF (ipcntr < 0) THEN
5654 WRITE(lup,*) '! Label Value Pre-sigma SkippedEntries Cons. group Status '
5655 ELSE
5656 WRITE(lup,*) '! Label Value Pre-sigma Entries Cons. group Status '
5657 END IF
5658 !iprlim=10
5659 DO itgbi=1,ntgb ! all parameter variables
5660 itgbl=globalparlabelindex(1,itgbi)
5661 ivgbi=globalparlabelindex(2,itgbi)
5662 icom=globalparcomments(itgbi) ! comment
5663 IF (icom > 0) WRITE(lup,117) listcomments(icom)%text
5664 c1=' '
5665 IF (globalparlabelindex(3,itgbi) == itgbl) c1='>'
5666 par=real(globalparameter(itgbi),mps) ! initial value
5667 presig=real(globalparpresigma(itgbi),mps) ! initial presigma
5668 icount=globalparlabelcounter(itgbi) ! from binary files
5669 IF (ipcntr < 0) icount=globalparlabelzeros(itgbi) ! 'zero derivatives' from binary files
5670 icgrp=globalparcons(itgbi) ! constraints group
5671
5672 IF (ivgbi <= 0) THEN
5673 ! not used
5674 IF (ivgbi == -4) THEN
5675 WRITE(lup,116) c1,itgbl,par,presig,icount,icgrp
5676 ELSE
5677 WRITE(lup,110) c1,itgbl,par,presig,icount,icgrp,ivgbi
5678 END IF
5679 ELSE
5680 ! variable
5681 WRITE(lup,111) c1,itgbl,par,presig,icount,icgrp
5682 END IF
5683 END DO
5684 ! appearance statistics
5685 IF (icheck > 1) THEN
5686 WRITE(lup,*) '!.'
5687 WRITE(lup,*) '!.Appearance statistics '
5688 WRITE(lup,*) '!. Label First file and record Last file and record #files #paired-par'
5689 DO itgbi=1,ntgb
5690 itpgrp=globalparlabelindex(4,itgbi)
5691 IF (itpgrp > 0) THEN
5692 WRITE(lup,112) globalparlabelindex(1,itgbi), (appearancecounter(itgbi*5+k), k=-4,0), paircounter(itpgrp)
5693 ELSE ! 'empty' parameter
5694 WRITE(lup,112) globalparlabelindex(1,itgbi)
5695 END IF
5696 END DO
5697 END IF
5698 IF (ncgrp > 0) THEN
5699 WRITE(lup,*) '* === constraint groups ==='
5700 IF (icheck == 1) THEN
5701 WRITE(lup,*) '* Group #Cons. Entries First label Last label'
5702 ELSE
5703 WRITE(lup,*) '* Group #Cons. Entries First label Last label Paired label range'
5704 length=ntpgrp+ncgrp
5705 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
5706 END IF
5707 DO icgrp=1, ncgrp
5708 IF (matconsgroups(2,icgrp) <= matconsgroups(3,icgrp)) THEN
5709 label1=globalparlabelindex(1,globalparvartototal(matconsgroups(2,icgrp))) ! first label
5710 label2=globalparlabelindex(1,globalparvartototal(matconsgroups(3,icgrp))) ! last label
5711 ELSE ! empty group/cons.
5712 label1=0
5713 label2=0
5714 END IF
5715 ncon=matconsgroups(1,icgrp+1)-matconsgroups(1,icgrp)
5716 WRITE(lup,113) icgrp, ncon,vecconsgroupcounts(icgrp),label1,label2
5717 IF (icheck > 1 .AND. label1 > 0) THEN
5718 ipgrp=globalparlabelindex(4,globalparvartototal(matconsgroups(2,icgrp))) ! first par. group
5719 ! get paired parameter groups
5720 CALL ggbmap(ntpgrp+icgrp,npair,vecpairedpargroups)
5721 vecpairedpargroups(npair+1)=0
5722 ifrst=0
5723 nstep=1
5724 DO j=1, npair
5725 jpgrp=vecpairedpargroups(j)
5726 inext=globaltotindexgroups(1,jpgrp)
5727 DO k=1,globaltotindexgroups(2,jpgrp)
5728 ! end of continous region ?
5729 IF (ifrst /= 0.AND.inext /= (ilast+nstep)) THEN
5730 label1=globalparlabelindex(1,ifrst)
5731 label2=globalparlabelindex(1,ilast)
5732 WRITE(lup,114) label1, label2
5733 ifrst=0
5734 END IF
5735 ! skip 'self-correlations'
5736 IF (globalparcons(inext) /= icgrp) THEN
5737 IF (ifrst == 0) ifrst=inext
5738 ilast=inext
5739 END IF
5740 inext=inext+1
5741 nstep=1
5742 END DO
5743 ! skip 'empty' parameter
5744 IF (jpgrp == vecpairedpargroups(j+1)-1) THEN
5745 nstep=globaltotindexgroups(1,vecpairedpargroups(j+1)) &
5746 -(globaltotindexgroups(1,jpgrp)+globaltotindexgroups(2,jpgrp)-1)
5747 END IF
5748 END DO
5749 IF (ifrst /= 0) THEN
5750 label1=globalparlabelindex(1,ifrst)
5751 label2=globalparlabelindex(1,ilast)
5752 WRITE(lup,114) label1, label2
5753 END IF
5754 END IF
5755 END DO
5756 IF (icheck > 1) THEN
5757 WRITE(lup,*) '*.'
5758 WRITE(lup,*) '*.Appearance statistics '
5759 WRITE(lup,*) '*. Group First file and record Last file and record #files'
5760 DO icgrp=1, ncgrp
5761 WRITE(lup,115) icgrp, (appearancecounter((ntgb+icgrp)*5+k), k=-4,0)
5762 END DO
5763 END IF
5764 END IF
5765
5766 rewind lup
5767 CLOSE(unit=lup)
5768
5769110 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' fixed',i2)
5770111 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' variable')
5771112 FORMAT(' !.',i10,6i11)
5772113 FORMAT(' * ',i6,i8,3i12)
5773114 FORMAT(' *:',48x,i12,' ..',i12)
5774115 FORMAT(' *.',i10,5i11)
5775116 FORMAT(' !',a1,i10,2x,2g14.5,2i12,' redundant')
5776117 FORMAT(' !!',a)
5777END SUBROUTINE prtstat ! print input statistics
5778
5779
5793
5794SUBROUTINE avprds(n,l,x,is,ie,b)
5795 USE mpmod
5796
5797 IMPLICIT NONE
5798 INTEGER(mpi) :: i
5799 INTEGER(mpi) :: ia
5800 INTEGER(mpi) :: ia2
5801 INTEGER(mpi) :: ib
5802 INTEGER(mpi) :: ib2
5803 INTEGER(mpi) :: in
5804 INTEGER(mpi) :: ipg
5805 INTEGER(mpi) :: iproc
5806 INTEGER(mpi) :: ir
5807 INTEGER(mpi) :: j
5808 INTEGER(mpi) :: ja
5809 INTEGER(mpi) :: ja2
5810 INTEGER(mpi) :: jb
5811 INTEGER(mpi) :: jb2
5812 INTEGER(mpi) :: jn
5813 INTEGER(mpi) :: lj
5814
5815 INTEGER(mpi), INTENT(IN) :: n
5816 INTEGER(mpl), INTENT(IN) :: l
5817 REAL(mpd), INTENT(IN) :: x(n)
5818 INTEGER(mpi), INTENT(IN) :: is
5819 INTEGER(mpi), INTENT(IN) :: ie
5820 REAL(mpd), INTENT(OUT) :: b(n)
5821 INTEGER(mpl) :: k
5822 INTEGER(mpl) :: kk
5823 INTEGER(mpl) :: ku
5824 INTEGER(mpl) :: ll
5825 INTEGER(mpl) :: indij
5826 INTEGER(mpl) :: indid
5827 INTEGER(mpl) :: ij
5828 INTEGER(mpi) :: ichunk
5829 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
5830 SAVE
5831 ! ...
5832
5833 ichunk=min((n+mthrd-1)/mthrd/8+1,128)
5834 IF(matsto /= 2) THEN
5835 ! full or unpacked (block diagonal) symmetric matrix
5836 ! parallelize row loop
5837 ! private copy of B(N) for each thread, combined at end, init with 0.
5838 ! slot of 128 'I' for next idle thread
5839 !$OMP PARALLEL DO &
5840 !$OMP PRIVATE(J,IJ) &
5841 !$OMP SCHEDULE(DYNAMIC,ichunk)
5842 DO i=1,n
5843 ij=globalrowoffsets(i+l)+l
5844 DO j=is,min(i,ie)
5845 b(i)=b(i)+globalmatd(ij+j)*x(j)
5846 END DO
5847 END DO
5848 !$OMP END PARALLEL DO
5849
5850 !$OMP PARALLEL DO &
5851 !$OMP PRIVATE(J,IJ) &
5852 !$OMP REDUCTION(+:B) &
5853 !$OMP SCHEDULE(DYNAMIC,ichunk)
5854 DO i=is,ie
5855 ij=globalrowoffsets(i+l)+l
5856 DO j=1,i-1
5857 b(j)=b(j)+globalmatd(ij+j)*x(i)
5858 END DO
5859 END DO
5860 !$OMP END PARALLEL DO
5861 ELSE
5862 ! sparse, compressed matrix
5863 IF(sparsematrixoffsets(2,1) /= n) THEN
5864 CALL peend(24,'Aborted, vector/matrix size mismatch')
5865 stop 'AVPRDS: mismatched vector and matrix'
5866 END IF
5867 ! parallelize row (group) loop
5868 ! slot of 1024 'I' for next idle thread
5869 !$OMP PARALLEL DO &
5870 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
5871 !$OMP PRIVATE(IA,IB,IN,JA,JB,IA2,IB2,JA2,JB2) &
5872 !$OMP REDUCTION(+:B) &
5873 !$OMP SCHEDULE(DYNAMIC,ichunk)
5874 DO ipg=1,napgrp
5875 iproc=0
5876 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
5877 ! row group
5878 ia=globalallindexgroups(ipg) ! first (global) row
5879 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
5880 in=ib-ia+1 ! number of rows
5881 ! overlap
5882 ia2=max(ia,is)
5883 ib2=min(ib,ie)
5884 ! diagonal elements
5885 IF (ia2 <= ib2) b(ia2:ib2)=b(ia2:ib2)+globalmatd(ia2:ib2)*x(ia2:ib2)
5886 ! off-diagonals double precision
5887 ir=ipg
5888 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5889 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5890 ku=sparsematrixoffsets(1,ir+1)-kk
5891 indid=kk
5892 indij=ll
5893 IF (ku > 0) THEN
5894 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5895 DO i=ia,ib
5896 IF (i <= ie.AND.i >= is) THEN
5897 DO k=1,ku
5898 j=sparsematrixcolumns(indid+k)
5899 b(j)=b(j)+globalmatd(indij+k)*x(i)
5900 END DO
5901 END IF
5902 DO k=1,ku
5903 j=sparsematrixcolumns(indid+k)
5904 IF (j <= ie.AND.j >= is) THEN
5905 b(i)=b(i)+globalmatd(indij+k)*x(j)
5906 END IF
5907 END DO
5908 indij=indij+ku
5909 END DO
5910 ELSE
5911 ! regions of continous column groups
5912 DO k=2,ku-2,2
5913 j=sparsematrixcolumns(indid+k) ! first group
5914 ja=globalallindexgroups(j) ! first (global) column
5915 lj=sparsematrixcolumns(indid+k-1) ! region offset
5916 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5917 jb=ja+jn-1 ! last (global) column
5918 ja2=max(ja,is)
5919 jb2=min(jb,ie)
5920 IF (ja2 <= jb2) THEN
5921 lj=1 ! index (in group region)
5922 DO i=ia,ib
5923 b(i)=b(i)+dot_product(globalmatd(indij+lj+ja2-ja:indij+lj+jb2-ja),x(ja2:jb2))
5924 lj=lj+jn
5925 END DO
5926 END IF
5927 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5928 lj=1
5929 DO j=ja,jb
5930 b(j)=b(j)+dot_product(globalmatd(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),x(ia2:ib2))
5931 lj=lj+1
5932 END DO
5933 END IF
5934 indij=indij+in*jn
5935 END DO
5936 END IF
5937 END IF
5938 ! mixed precision
5939 IF (nspc > 1) THEN
5940 ir=ipg+napgrp+1 ! off-diagonals single precision
5941 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
5942 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
5943 ku=sparsematrixoffsets(1,ir+1)-kk
5944 indid=kk
5945 indij=ll
5946 IF (ku == 0) cycle
5947 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
5948 DO i=ia,ib
5949 IF (i <= ie.AND.i >= is) THEN
5950 DO k=1,ku
5951 j=sparsematrixcolumns(indid+k)
5952 b(j)=b(j)+globalmatf(indij+k)*x(i)
5953 END DO
5954 END IF
5955 DO k=1,ku
5956 j=sparsematrixcolumns(indid+k)
5957 IF (j <= ie.AND.j >= is) THEN
5958 b(i)=b(i)+globalmatf(indij+k)*x(j)
5959 END IF
5960 END DO
5961 indij=indij+ku
5962 END DO
5963 ELSE
5964 ! regions of continous column groups
5965 DO k=2,ku-2,2
5966 j=sparsematrixcolumns(indid+k) ! first group
5967 ja=globalallindexgroups(j) ! first (global) column
5968 lj=sparsematrixcolumns(indid+k-1) ! region offset
5969 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
5970 jb=ja+jn-1 ! last (global) column
5971 ja2=max(ja,is)
5972 jb2=min(jb,ie)
5973 IF (ja2 <= jb2) THEN
5974 lj=1 ! index (in group region)
5975 DO i=ia,ib
5976 b(i)=b(i)+dot_product(real(globalmatf(indij+lj+ja2-ja:indij+lj+jb2-ja),mpd),x(ja2:jb2))
5977 lj=lj+jn
5978 END DO
5979 END IF
5980 IF (mextnd == 0.AND.ia2 <= ib2) THEN
5981 lj=1
5982 DO j=ja,jb
5983 b(j)=b(j)+dot_product(real(globalmatf(indij+lj+jn*(ia2-ia):indij+lj+jn*(ib2-ia):jn),mpd),x(ia2:ib2))
5984 lj=lj+1
5985 END DO
5986 END IF
5987 indij=indij+in*jn
5988 END DO
5989 END IF
5990 END IF
5991 END DO
5992 ENDIF
5993
5994END SUBROUTINE avprds
5995
6007
6008SUBROUTINE avprd0(n,l,x,b)
6009 USE mpmod
6010
6011 IMPLICIT NONE
6012 INTEGER(mpi) :: i
6013 INTEGER(mpi) :: ia
6014 INTEGER(mpi) :: ib
6015 INTEGER(mpi) :: in
6016 INTEGER(mpi) :: ipg
6017 INTEGER(mpi) :: iproc
6018 INTEGER(mpi) :: ir
6019 INTEGER(mpi) :: j
6020 INTEGER(mpi) :: ja
6021 INTEGER(mpi) :: jb
6022 INTEGER(mpi) :: jn
6023 INTEGER(mpi) :: lj
6024
6025 INTEGER(mpi), INTENT(IN) :: n
6026 INTEGER(mpl), INTENT(IN) :: l
6027 REAL(mpd), INTENT(IN) :: x(n)
6028 REAL(mpd), INTENT(OUT) :: b(n)
6029 INTEGER(mpl) :: k
6030 INTEGER(mpl) :: kk
6031 INTEGER(mpl) :: ku
6032 INTEGER(mpl) :: ll
6033 INTEGER(mpl) :: indij
6034 INTEGER(mpl) :: indid
6035 INTEGER(mpl) :: ij
6036 INTEGER(mpi) :: ichunk
6037 !$ INTEGER(mpi) OMP_GET_THREAD_NUM
6038 SAVE
6039 ! ...
6040 !$ DO i=1,n
6041 !$ b(i)=0.0_mpd ! reset 'global' B()
6042 !$ END DO
6043 ichunk=min((n+mthrd-1)/mthrd/8+1,1024)
6044 IF(matsto /= 2) THEN
6045 ! full or unpacked (block diagonal) symmetric matrix
6046 ! parallelize row loop
6047 ! private copy of B(N) for each thread, combined at end, init with 0.
6048 ! slot of 1024 'I' for next idle thread
6049 !$OMP PARALLEL DO &
6050 !$OMP PRIVATE(J,IJ) &
6051 !$OMP REDUCTION(+:B) &
6052 !$OMP SCHEDULE(DYNAMIC,ichunk)
6053 DO i=1,n
6054 ij=globalrowoffsets(i+l)+l
6055 b(i)=globalmatd(ij+i)*x(i)
6056 DO j=1,i-1
6057 b(j)=b(j)+globalmatd(ij+j)*x(i)
6058 b(i)=b(i)+globalmatd(ij+j)*x(j)
6059 END DO
6060 END DO
6061 !$OMP END PARALLEL DO
6062 ELSE
6063 ! sparse, compressed matrix
6064 IF(sparsematrixoffsets(2,1) /= n) THEN
6065 CALL peend(24,'Aborted, vector/matrix size mismatch')
6066 stop 'AVPRD0: mismatched vector and matrix'
6067 END IF
6068 ! parallelize row (group) loop
6069 ! slot of 1024 'I' for next idle thread
6070 !$OMP PARALLEL DO &
6071 !$OMP PRIVATE(I,IR,K,KK,LL,KU,INDID,INDIJ,J,JN,LJ) &
6072 !$OMP PRIVATE(IA,IB,IN,JA,JB) &
6073 !$OMP REDUCTION(+:B) &
6074 !$OMP SCHEDULE(DYNAMIC,ichunk)
6075 DO ipg=1,napgrp
6076 iproc=0
6077 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
6078 ! row group
6079 ia=globalallindexgroups(ipg) ! first (global) row
6080 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6081 in=ib-ia+1 ! number of rows
6082 !
6083 ! diagonal elements
6084 b(ia:ib)=globalmatd(ia:ib)*x(ia:ib)
6085 ! off-diagonals double precision
6086 ir=ipg
6087 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6088 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6089 ku=sparsematrixoffsets(1,ir+1)-kk
6090 indid=kk
6091 indij=ll
6092 IF (ku > 0) THEN
6093 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6094 DO i=ia,ib
6095 DO k=1,ku
6096 j=sparsematrixcolumns(indid+k)
6097 b(j)=b(j)+globalmatd(indij+k)*x(i)
6098 b(i)=b(i)+globalmatd(indij+k)*x(j)
6099 END DO
6100 indij=indij+ku
6101 END DO
6102 ELSE
6103 ! regions of continous column groups
6104 DO k=2,ku-2,2
6105 j=sparsematrixcolumns(indid+k) ! first group
6106 ja=globalallindexgroups(j) ! first (global) column
6107 lj=sparsematrixcolumns(indid+k-1) ! region offset
6108 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6109 jb=ja+jn-1 ! last (global) column
6110 lj=1 ! index (in group region)
6111 DO i=ia,ib
6112 b(i)=b(i)+dot_product(globalmatd(indij+lj:indij+lj+jn-1),x(ja:jb))
6113 lj=lj+jn
6114 END DO
6115 IF (mextnd == 0) THEN
6116 lj=1
6117 DO j=ja,jb
6118 b(j)=b(j)+dot_product(globalmatd(indij+lj:indij+jn*in:jn),x(ia:ib))
6119 lj=lj+1
6120 END DO
6121 END IF
6122 indij=indij+in*jn
6123 END DO
6124 END IF
6125 END IF
6126 ! mixed precision
6127 IF (nspc > 1) THEN
6128 ir=ipg+napgrp+1 ! off-diagonals single precision
6129 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6130 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6131 ku=sparsematrixoffsets(1,ir+1)-kk
6132 indid=kk
6133 indij=ll
6134 IF (ku == 0) cycle
6135 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6136 DO i=ia,ib
6137 DO k=1,ku
6138 j=sparsematrixcolumns(indid+k)
6139 b(j)=b(j)+real(globalmatf(indij+k),mpd)*x(i)
6140 b(i)=b(i)+real(globalmatf(indij+k),mpd)*x(j)
6141 END DO
6142 indij=indij+ku
6143 END DO
6144 ELSE
6145 ! regions of continous column groups
6146 DO k=2,ku-2,2
6147 j=sparsematrixcolumns(indid+k) ! first group
6148 ja=globalallindexgroups(j) ! first (global) column
6149 lj=sparsematrixcolumns(indid+k-1) ! region offset
6150 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6151 jb=ja+jn-1 ! last (global) column
6152 lj=1 ! index (in group region)
6153 DO i=ia,ib
6154 b(i)=b(i)+dot_product(real(globalmatf(indij+lj:indij+lj+jn-1),mpd),x(ja:jb))
6155 lj=lj+jn
6156 END DO
6157 IF (mextnd == 0) THEN
6158 lj=1
6159 DO j=ja,jb
6160 b(j)=b(j)+dot_product(real(globalmatf(indij+lj:indij+jn*in:jn),mpd),x(ia:ib))
6161 lj=lj+1
6162 END DO
6163 END IF
6164 indij=indij+in*jn
6165 END DO
6166 END IF
6167 END IF
6168 END DO
6169 ENDIF
6170
6171END SUBROUTINE avprd0
6172
6173
6176SUBROUTINE anasps
6177 USE mpmod
6178
6179 IMPLICIT NONE
6180 INTEGER(mpi) :: ia
6181 INTEGER(mpi) :: ib
6182 INTEGER(mpi) :: ipg
6183 INTEGER(mpi) :: ir
6184 INTEGER(mpi) :: ispc
6185 INTEGER(mpi) :: lj
6186 REAL(mps) :: avg
6187
6188
6189 INTEGER(mpl) :: in
6190 INTEGER(mpl) :: jn
6191 INTEGER(mpl) :: k
6192 INTEGER(mpl) :: kk
6193 INTEGER(mpl) :: ku
6194 INTEGER(mpl) :: ll
6195 INTEGER(mpl) :: indid
6196 INTEGER(mpl), DIMENSION(12) :: icount
6197 SAVE
6198
6199 ! require sparse storage
6200 IF(matsto /= 2) RETURN
6201 ! reset
6202 icount=0
6203 icount(4)=huge(icount(4))
6204 icount(7)=huge(icount(7))
6205 icount(10)=huge(icount(10))
6206 ! loop over precisions
6207 DO ispc=1,nspc
6208 ! loop over row groups
6209 DO ipg=1,napgrp
6210 ! row group
6211 ia=globalallindexgroups(ipg) ! first (global) row
6212 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6213 in=ib-ia+1 ! number of rows
6214
6215 ir=ipg+(ispc-1)*(napgrp+1)
6216 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6217 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6218 ku=sparsematrixoffsets(1,ir+1)-kk
6219 indid=kk
6220 IF (ku == 0) cycle
6221 IF (sparsematrixcolumns(indid+1) /= 0) THEN ! no compression
6222 icount(1)=icount(1)+in
6223 icount(2)=icount(2)+in*ku
6224 ELSE
6225 ! regions of continous column groups
6226 DO k=2,ku-2,2
6227 lj=sparsematrixcolumns(indid+k-1) ! region offset
6228 jn=sparsematrixcolumns(indid+k+1)-lj ! number of columns
6229 icount(3)=icount(3)+1 ! block (region) counter
6230 icount(4)=min(icount(4),jn) ! min number of columns per block (region)
6231 icount(5)=icount(5)+jn ! sum number of columns per block (region)
6232 icount(6)=max(icount(6),jn) ! max number of columns per block (region)
6233 icount(7)=min(icount(7),in) ! min number of rows per block (region)
6234 icount(8)=icount(8)+in ! sum number of rows per block (region)
6235 icount(9)=max(icount(9),in) ! max number of rows per block (region)
6236 icount(10)=min(icount(10),in*jn) ! min number of elements per block (region)
6237 icount(11)=icount(11)+in*jn ! sum number of elements per block (region)
6238 icount(12)=max(icount(12),in*jn) ! max number of elements per block (region)
6239 END DO
6240 END IF
6241 END DO
6242 END DO
6243
6244 WRITE(*,*) "analysis of sparsity structure"
6245 IF (icount(1) > 0) THEN
6246 WRITE(*,101) "rows without compression/blocks ", icount(1)
6247 WRITE(*,101) " contained elements ", icount(2)
6248 ENDIF
6249 WRITE(*,101) "number of block matrices ", icount(3)
6250 avg=real(icount(5),mps)/real(icount(3),mps)
6251 WRITE(*,101) "number of columns (min,mean,max) ", icount(4), avg, icount(6)
6252 avg=real(icount(8),mps)/real(icount(3),mps)
6253 WRITE(*,101) "number of rows (min,mean,max) ", icount(7), avg, icount(9)
6254 avg=real(icount(11),mps)/real(icount(3),mps)
6255 WRITE(*,101) "number of elements (min,mean,max) ", icount(10), avg, icount(12)
6256101 FORMAT(2x,a34,i10,f10.3,i10)
6257
6258END SUBROUTINE anasps
6259
6269
6270SUBROUTINE avprod(n,x,b)
6271 USE mpmod
6272
6273 IMPLICIT NONE
6274
6275 INTEGER(mpi), INTENT(IN) :: n
6276 REAL(mpd), INTENT(IN) :: x(n)
6277 REAL(mpd), INTENT(OUT) :: b(n)
6278
6279 SAVE
6280 ! ...
6281 IF(n > nagb) THEN
6282 CALL peend(24,'Aborted, vector/matrix size mismatch')
6283 stop 'AVPROD: mismatched vector and matrix'
6284 END IF
6285 ! input to AVPRD0
6286 vecxav(1:n)=x
6287 vecxav(n+1:nagb)=0.0_mpd
6288 !use elimination for constraints ?
6289 IF(n < nagb) CALL qlmlq(vecxav,1,.false.) ! Q*x
6290 ! calclulate vecBav=globalMat*vecXav
6291 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
6292 !use elimination for constraints ?
6293 IF(n < nagb) CALL qlmlq(vecbav,1,.true.) ! Q^t*x
6294 ! output from AVPRD0
6295 b=vecbav(1:n)
6296
6297END SUBROUTINE avprod
6298
6299
6309
6310SUBROUTINE ijpgrp(itema,itemb,ij,lr,iprc)
6311 USE mpmod
6312
6313 IMPLICIT NONE
6314 INTEGER(mpi) :: ispc
6315 INTEGER(mpi) :: item1
6316 INTEGER(mpi) :: item2
6317 INTEGER(mpi) :: itemc
6318 INTEGER(mpi) :: jtem
6319 INTEGER(mpi) :: jtemn
6320 INTEGER(mpi) :: np
6321
6322 INTEGER(mpi), INTENT(IN) :: itema
6323 INTEGER(mpi), INTENT(IN) :: itemb
6324 INTEGER(mpl), INTENT(OUT) :: ij
6325 INTEGER(mpi), INTENT(OUT) :: lr
6326 INTEGER(mpi), INTENT(OUT) :: iprc
6327
6328 INTEGER(mpl) :: k
6329 INTEGER(mpl) :: kk
6330 INTEGER(mpl) :: kl
6331 INTEGER(mpl) :: ku
6332 INTEGER(mpl) :: ll
6333 ! ...
6334 ij=0
6335 lr=0
6336 iprc=0
6337 item1=max(itema,itemb) ! larger index
6338 item2=min(itema,itemb) ! smaller index
6339 IF(item2 <= 0.OR.item1 > napgrp) RETURN
6340 np=globalallindexgroups(item1+1)-globalallindexgroups(item1) ! size of group item1
6341 ! loop over precisions
6342 outer: DO ispc=1,nspc
6343 kk=sparsematrixoffsets(1,item1) ! offset (column lists)
6344 ll=sparsematrixoffsets(2,item1) ! offset (matrix)
6345 kl=1
6346 ku=sparsematrixoffsets(1,item1+1)-kk
6347 item1=item1+napgrp+1
6348 iprc=ispc
6349 IF (sparsematrixcolumns(kk+1) == 0) THEN ! compression ?
6350 ! compressed (list of continous regions of parameter groups (pairs of offset and 1. group index)
6351 kl=2
6352 ku=ku-2
6353 IF(ku < kl) cycle outer ! not found
6354 DO
6355 k=2*((kl+ku)/4) ! binary search
6356 jtem=sparsematrixcolumns(kk+k) ! first column (group) of region
6357 jtemn=sparsematrixcolumns(kk+k+2) ! first column (group) after region
6358 IF(item2 >= jtem.AND.item2 < jtemn) THEN
6359 ! length of region
6360 lr=sparsematrixcolumns(kk+k+1)-sparsematrixcolumns(kk+k-1)
6361 IF (globalallindexgroups(item2)-globalallindexgroups(jtem) >= lr) cycle outer ! outside region
6362 EXIT ! found
6363 END IF
6364 IF(item2 < jtem) THEN
6365 ku=k-2
6366 ELSE IF(item2 >= jtemn) THEN
6367 kl=k+2
6368 END IF
6369 IF(kl <= ku) cycle
6370 cycle outer ! not found
6371 END DO
6372 ! group offset in row
6373 ij=sparsematrixcolumns(kk+k-1)
6374 ! absolute offset
6375 ij=ll+ij*np+globalallindexgroups(item2)-globalallindexgroups(jtem)+1
6376
6377 ELSE
6378 ! simple column list
6379 itemc=globalallindexgroups(item2) ! first (col) index of group
6380 lr=int(ku,mpi) ! number of columns
6381 IF(ku < kl) cycle outer ! not found
6382 DO
6383 k=(kl+ku)/2 ! binary search
6384 jtem=sparsematrixcolumns(kk+k)
6385 IF(itemc == jtem) EXIT ! found
6386 IF(itemc < jtem) THEN
6387 ku=k-1
6388 ELSE IF(itemc > jtem) THEN
6389 kl=k+1
6390 END IF
6391 IF(kl <= ku) cycle
6392 cycle outer ! not found
6393 END DO
6394 ij=ll+k
6395
6396 END IF
6397 RETURN
6398 END DO outer
6399
6400END SUBROUTINE ijpgrp
6401
6407
6408FUNCTION ijprec(itema,itemb)
6409 USE mpmod
6410
6411 IMPLICIT NONE
6412
6413 INTEGER(mpi) :: lr
6414 INTEGER(mpl) :: ij
6415
6416 INTEGER(mpi), INTENT(IN) :: itema
6417 INTEGER(mpi), INTENT(IN) :: itemb
6418 INTEGER(mpi) :: ijprec
6419
6420 ! ...
6421 ijprec=1
6422 IF (matsto == 2.AND.nspc > 1) THEN ! sparse storage with mixed precision
6423 ! check groups
6424 CALL ijpgrp(itema,itemb,ij,lr,ijprec)
6425 END IF
6426
6427END FUNCTION ijprec
6428
6436
6437FUNCTION ijadd(itema,itemb) ! index using "d" and "z"
6438 USE mpmod
6439
6440 IMPLICIT NONE
6441
6442 INTEGER(mpi) :: item1
6443 INTEGER(mpi) :: item2
6444 INTEGER(mpi) :: ipg1
6445 INTEGER(mpi) :: ipg2
6446 INTEGER(mpi) :: lr
6447 INTEGER(mpi) :: iprc
6448
6449 INTEGER(mpi), INTENT(IN) :: itema
6450 INTEGER(mpi), INTENT(IN) :: itemb
6451
6452 INTEGER(mpl) :: ijadd
6453 INTEGER(mpl) :: ij
6454 ! ...
6455 ijadd=0
6456 item1=max(itema,itemb) ! larger index
6457 item2=min(itema,itemb) ! smaller index
6458 !print *, ' ijadd ', item1, item2
6459 IF(item2 <= 0.OR.item1 > nagb) RETURN
6460 IF(item1 == item2) THEN ! diagonal element
6461 ijadd=item1
6462 RETURN
6463 END IF
6464 ! ! off-diagonal element
6465 ! get parameter groups
6466 ipg1=globalallpartogroup(item1)
6467 ipg2=globalallpartogroup(item2)
6468 ! get offset for groups
6469 CALL ijpgrp(ipg1,ipg2,ij,lr,iprc)
6470 IF (ij == 0) RETURN
6471 ! add offset inside groups
6472 ijadd=ij+(item2-globalallindexgroups(ipg2))+(item1-globalallindexgroups(ipg1))*lr
6473 ! reduced precision?
6474 IF (iprc > 1) ijadd=-ijadd
6475
6476END FUNCTION ijadd
6477
6485
6486FUNCTION ijcsr3(itema,itemb) ! index using "d" and "z"
6487 USE mpmod
6488
6489 IMPLICIT NONE
6490
6491 INTEGER(mpi) :: item1
6492 INTEGER(mpi) :: item2
6493 INTEGER(mpi) :: jtem
6494
6495 INTEGER(mpi), INTENT(IN) :: itema
6496 INTEGER(mpi), INTENT(IN) :: itemb
6497
6498 INTEGER(mpl) :: ijcsr3
6499 INTEGER(mpl) :: kk
6500 INTEGER(mpl) :: ks
6501 INTEGER(mpl) :: ke
6502
6503 ! ...
6504 ijcsr3=0
6505 item1=max(itema,itemb) ! larger index
6506 item2=min(itema,itemb) ! smaller index
6507 !print *, ' ijadd ', item1, item2
6508 IF(item2 <= 0.OR.item1 > nagb) RETURN
6509 ! start of column list for row
6510 ks=csr3rowoffsets(item2)
6511 ! end of column list for row
6512 ke=csr3rowoffsets(item2+1)-1
6513 ! binary search
6514 IF(ke < ks) THEN
6515 ! empty list
6516 print *, ' IJCSR3 empty list ', item1, item2, ks, ke
6517 CALL peend(23,'Aborted, bad matrix index')
6518 stop 'ijcsr3: empty list'
6519 ENDIF
6520 DO
6521 kk=(ks+ke)/2 ! center of rgion
6522 jtem=int(csr3columnlist(kk),mpi)
6523 IF(item1 == jtem) EXIT ! found
6524 IF(item1 < jtem) THEN
6525 ke=kk-1
6526 ELSE
6527 ks=kk+1
6528 END IF
6529 IF(ks <= ke) cycle
6530 ! not found
6531 print *, ' IJCSR3 not found ', item1, item2, ks, ke
6532 CALL peend(23,'Aborted, bad matrix index')
6533 stop 'ijcsr3: not found'
6534 END DO
6535 ijcsr3=kk
6536END FUNCTION ijcsr3
6537
6543
6544FUNCTION matij(itema,itemb)
6545 USE mpmod
6546
6547 IMPLICIT NONE
6548
6549 INTEGER(mpi) :: item1
6550 INTEGER(mpi) :: item2
6551 INTEGER(mpl) :: i
6552 INTEGER(mpl) :: j
6553 INTEGER(mpl) :: ij
6554 INTEGER(mpl) :: ijadd
6555 INTEGER(mpl) :: ijcsr3
6556
6557 INTEGER(mpi), INTENT(IN) :: itema
6558 INTEGER(mpi), INTENT(IN) :: itemb
6559
6560 REAL(mpd) :: matij
6561 ! ...
6562 matij=0.0_mpd
6563 item1=max(itema,itemb) ! larger index
6564 item2=min(itema,itemb) ! smaller index
6565 IF(item2 <= 0.OR.item1 > nagb) RETURN
6566
6567 i=item1
6568 j=item2
6569
6570 IF(matsto < 2) THEN ! full or unpacked (block diagonal) symmetric matrix
6571 ij=globalrowoffsets(i)+j
6572 matij=globalmatd(ij)
6573 ELSE IF(matsto ==2) THEN ! sparse symmetric matrix (custom)
6574 ij=ijadd(item1,item2) ! inline code requires same time
6575 IF(ij > 0) THEN
6576 matij=globalmatd(ij)
6577 ELSE IF (ij < 0) THEN
6578 matij=real(globalmatf(-ij),mpd)
6579 END IF
6580 ELSE ! sparse symmetric matrix (CSR3)
6581 IF(matbsz < 2) THEN ! sparse symmetric matrix (CSR3)
6582 ij=ijcsr3(item1,item2) ! inline code requires same time
6583 IF(ij > 0) matij=globalmatd(ij)
6584 ELSE ! sparse symmetric matrix (BSR3)
6585 ! block index
6586 ij=ijcsr3((item1-1)/matbsz+1,(item2-1)/matbsz+1)
6587 IF (ij > 0) THEN
6588 ! index of first element in block
6589 ij=(ij-1)*matbsz*matbsz+1
6590 ! adjust index for position in block
6591 ij=ij+mod(item1-1,matbsz)*matbsz+mod(item2-1,matbsz)
6592 matij=globalmatd(ij)
6593 ENDIF
6594 END IF
6595 END IF
6596
6597END FUNCTION matij
6598
6601
6602SUBROUTINE mhalf2
6603 USE mpmod
6604
6605 IMPLICIT NONE
6606 INTEGER(mpi) :: i
6607 INTEGER(mpi) :: ia
6608 INTEGER(mpi) :: ib
6609 INTEGER(mpi) :: ichunk
6610 INTEGER(mpi) :: in
6611 INTEGER(mpi) :: ipg
6612 INTEGER(mpi) :: ir
6613 INTEGER(mpi) :: ispc
6614 INTEGER(mpi) :: j
6615 INTEGER(mpi) :: ja
6616 INTEGER(mpi) :: jb
6617 INTEGER(mpi) :: jn
6618 INTEGER(mpi) :: lj
6619
6620 INTEGER(mpl) :: ij
6621 INTEGER(mpl) :: ijadd
6622 INTEGER(mpl) :: k
6623 INTEGER(mpl) :: kk
6624 INTEGER(mpl) :: ku
6625 INTEGER(mpl) :: ll
6626 ! ...
6627
6628 ichunk=min((napgrp+mthrd-1)/mthrd/8+1,1024)
6629
6630 DO ispc=1,nspc
6631 ! parallelize row loop
6632 ! slot of 1024 'I' for next idle thread
6633 !$OMP PARALLEL DO &
6634 !$OMP PRIVATE(I,IR,K,KK,LL,KU,IJ,J,LJ) &
6635 !$OMP PRIVATE(IA,IB,IN,JA,JB,JN) &
6636 !$OMP SCHEDULE(DYNAMIC,ichunk)
6637 DO ipg=1,napgrp
6638 ! row group
6639 ia=globalallindexgroups(ipg) ! first (global) row
6640 ib=globalallindexgroups(ipg+1)-1 ! last (global) row
6641 in=ib-ia+1 ! number of rows
6642 !
6643 ir=ipg+(ispc-1)*(napgrp+1)
6644 kk=sparsematrixoffsets(1,ir) ! offset in 'd' (column lists)
6645 ll=sparsematrixoffsets(2,ir) ! offset in 'j' (matrix)
6646 ku=sparsematrixoffsets(1,ir+1)-kk
6647 ! regions of continous column groups
6648 DO k=2,ku-2,2
6649 j=sparsematrixcolumns(kk+k) ! first group
6650 ja=globalallindexgroups(j) ! first (global) column
6651 lj=sparsematrixcolumns(kk+k-1) ! region offset
6652 jn=sparsematrixcolumns(kk+k+1)-lj ! number of columns
6653 jb=ja+jn-1 ! last (global) column
6654 ! skip first half
6655 IF (sparsematrixcolumns(kk+k+2) <= ipg) THEN
6656 ll=ll+in*jn
6657 cycle
6658 END IF
6659 ! at diagonal or in second half
6660 DO i=ia,ib ! loop over rows
6661 DO j=ja,jb ! loop over columns
6662 ll=ll+1
6663 IF (j > i) THEN
6664 ij=ijadd(i,j)
6665 IF (ispc==1) THEN
6666 globalmatd(ll)=globalmatd(ij)
6667 ELSE
6668 globalmatf(ll)=globalmatf(-ij)
6669 END IF
6670 END IF
6671 END DO
6672 END DO
6673 END DO
6674 END DO
6675 !$OMP END PARALLEL DO
6676 END DO
6677
6678END SUBROUTINE mhalf2
6679
6688
6689SUBROUTINE sechms(deltat,nhour,minut,secnd)
6690 USE mpdef
6691
6692 IMPLICIT NONE
6693 REAL(mps), INTENT(IN) :: deltat
6694 INTEGER(mpi), INTENT(OUT) :: minut
6695 INTEGER(mpi), INTENT(OUT):: nhour
6696 REAL(mps), INTENT(OUT):: secnd
6697 INTEGER(mpi) :: nsecd
6698 ! DELTAT = time in sec -> NHOUR,MINUT,SECND
6699 ! ...
6700 nsecd=nint(deltat,mpi) ! -> integer
6701 nhour=nsecd/3600
6702 minut=nsecd/60-60*nhour
6703 secnd=deltat-60*(minut+60*nhour)
6704END SUBROUTINE sechms
6705
6733
6734INTEGER(mpi) FUNCTION inone(item) ! translate 1-D identifier to nrs
6735 USE mpmod
6736 USE mpdalc
6737
6738 IMPLICIT NONE
6739 INTEGER(mpi), INTENT(IN) :: item
6740 INTEGER(mpi) :: j
6741 INTEGER(mpi) :: k
6742 INTEGER(mpi) :: iprime
6743 INTEGER(mpl) :: length
6744 INTEGER(mpl), PARAMETER :: four = 4
6745
6746 inone=0
6747 !print *, ' INONE ', item
6748 IF(item <= 0) RETURN
6749 IF(globalparheader(-1) == 0) THEN
6750 length=128 ! initial number
6751 CALL mpalloc(globalparlabelindex,four,length,'INONE: label & index')
6752 CALL mpalloc(globalparlabelcounter,length,'INONE: counter') ! updated in pargrp
6753 CALL mpalloc(globalparhashtable,2*length,'INONE: hash pointer')
6755 globalparheader(-0)=int(length,mpi) ! length of labels/indices
6756 globalparheader(-1)=0 ! number of stored items
6757 globalparheader(-2)=0 ! =0 during build-up
6758 globalparheader(-3)=int(length,mpi) ! next number
6759 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number
6760 globalparheader(-5)=0 ! number of overflows
6761 globalparheader(-6)=0 ! nr of variable parameters
6762 globalparheader(-8)=0 ! number of sorted items
6763 END IF
6764 outer: DO
6765 j=1+mod(item,globalparheader(-4))+globalparheader(-0)
6766 inner: DO ! normal case: find item
6767 k=j
6769 IF(j == 0) EXIT inner ! unused hash code
6770 IF(item == globalparlabelindex(1,j)) EXIT outer ! found
6771 END DO inner
6772 ! not found
6773 IF(globalparheader(-1) == globalparheader(-0).OR.globalparheader(-2) /= 0) THEN
6774 globalparheader(-5)=globalparheader(-5)+1 ! overflow
6775 j=0
6776 RETURN
6777 END IF
6778 globalparheader(-1)=globalparheader(-1)+1 ! increase number of elements
6780 j=globalparheader(-1)
6781 globalparhashtable(k)=j ! hash index
6782 globalparlabelindex(1,j)=item ! add new item
6783 globalparlabelindex(2,j)=0 ! reset index (for variable par.)
6784 globalparlabelindex(3,j)=0 ! reset group info (first label)
6785 globalparlabelindex(4,j)=0 ! reset group info (group index)
6786 globalparlabelcounter(j)=0 ! reset (long) counter
6787 IF(globalparheader(-1) /= globalparheader(-0)) EXIT outer
6788 ! update with larger dimension and redefine index
6790 CALL upone
6791 IF (lvllog > 1) WRITE(lunlog,*) 'INONE: array increased to', &
6792 globalparheader(-3),' words'
6793 END DO outer
6794
6795 ! counting now in pargrp
6796 !IF(globalParHeader(-2) == 0) THEN
6797 ! globalParLabelIndex(2,j)=globalParLabelIndex(2,j)+1 ! increase counter
6798 ! globalParHeader(-7)=globalParHeader(-7)+1
6799 !END IF
6800 inone=j
6801END FUNCTION inone
6802
6804SUBROUTINE upone
6805 USE mpmod
6806 USE mpdalc
6807
6808 IMPLICIT NONE
6809 INTEGER(mpi) :: i
6810 INTEGER(mpi) :: j
6811 INTEGER(mpi) :: k
6812 INTEGER(mpi) :: iprime
6813 INTEGER(mpi) :: nused
6814 LOGICAL :: finalUpdate
6815 INTEGER(mpl) :: oldLength
6816 INTEGER(mpl) :: newLength
6817 INTEGER(mpl), PARAMETER :: four = 4
6818 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArr
6819 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: tempVec
6820 SAVE
6821 ! ...
6822 finalupdate=(globalparheader(-3) == globalparheader(-1))
6823 IF(finalupdate) THEN ! final (cleanup) call
6824 IF (globalparheader(-1) > globalparheader(-8)) THEN
6827 END IF
6828 END IF
6829 ! save old LabelIndex
6830 nused = globalparheader(-1)
6831 oldlength = globalparheader(-0)
6832 CALL mpalloc(temparr,four,oldlength,'INONE: temp array')
6833 temparr(:,1:nused)=globalparlabelindex(:,1:nused)
6834 CALL mpalloc(tempvec,oldlength,'INONE: temp vector')
6835 tempvec(1:nused)=globalparlabelcounter(1:nused)
6839 ! create new LabelIndex
6840 newlength = globalparheader(-3)
6841 CALL mpalloc(globalparlabelindex,four,newlength,'INONE: label & index')
6842 CALL mpalloc(globalparlabelcounter,newlength,'INONE: counter')
6843 CALL mpalloc(globalparhashtable,2*newlength,'INONE: hash pointer')
6845 globalparlabelindex(:,1:nused) = temparr(:,1:nused) ! copy back saved content
6846 globalparlabelcounter(1:nused) = tempvec(1:nused) ! copy back saved content
6847 CALL mpdealloc(tempvec)
6848 CALL mpdealloc(temparr)
6849 globalparheader(-0)=int(newlength,mpi) ! length of labels/indices
6851 globalparheader(-4)=iprime(globalparheader(-0)) ! prime number < LNDA
6852 ! redefine hash
6853 outer: DO i=1,globalparheader(-1)
6855 inner: DO
6856 k=j
6858 IF(j == 0) EXIT inner ! unused hash code
6859 IF(j == i) cycle outer ! found
6860 ENDDO inner
6862 END DO outer
6863 IF(.NOT.finalupdate) RETURN
6864
6865 globalparheader(-2)=1 ! set flag to inhibit further updates
6866 IF (lvllog > 1) THEN
6867 WRITE(lunlog,*) ' '
6868 WRITE(lunlog,*) 'INONE: array reduced to',newlength,' words'
6869 WRITE(lunlog,*) 'INONE:',globalparheader(-1),' items stored.'
6870 END IF
6871END SUBROUTINE upone ! update, redefine
6872
6874SUBROUTINE useone
6875 USE mpmod
6876
6877 IMPLICIT NONE
6878 INTEGER(mpi) :: i
6879 INTEGER(mpi) :: j
6880 INTEGER(mpi) :: k
6881 SAVE
6882 ! ...
6883 IF (globalparheader(-1) > globalparheader(-8)) THEN
6885 ! redefine hash
6887 outer: DO i=1,globalparheader(-1)
6889 inner: DO
6890 k=j
6892 IF(j == 0) EXIT inner ! unused hash code
6893 IF(j == i) cycle outer ! found
6894 ENDDO inner
6896 END DO outer
6898 END IF
6899END SUBROUTINE useone ! make usable
6900
6905
6906INTEGER(mpi) FUNCTION iprime(n)
6907 USE mpdef
6908
6909 IMPLICIT NONE
6910 INTEGER(mpi), INTENT(IN) :: n
6911 INTEGER(mpi) :: nprime
6912 INTEGER(mpi) :: nsqrt
6913 INTEGER(mpi) :: i
6914 ! ...
6915 SAVE
6916 nprime=n ! max number
6917 IF(mod(nprime,2) == 0) nprime=nprime+1 ! ... odd number
6918 outer: DO
6919 nprime=nprime-2 ! next lower odd number
6920 nsqrt=int(sqrt(real(nprime,mps)),mpi)
6921 DO i=3,nsqrt,2 !
6922 IF(i*(nprime/i) == nprime) cycle outer ! test prime number
6923 END DO
6924 EXIT outer ! found
6925 END DO outer
6926 iprime=nprime
6927END FUNCTION iprime
6928
6938SUBROUTINE loop1
6939 USE mpmod
6940 USE mpdalc
6941
6942 IMPLICIT NONE
6943 INTEGER(mpi) :: i
6944 INTEGER(mpi) :: idum
6945 INTEGER(mpi) :: in
6946 INTEGER(mpi) :: indab
6947 INTEGER(mpi) :: itgbi
6948 INTEGER(mpi) :: itgbl
6949 INTEGER(mpi) :: ivgbi
6950 INTEGER(mpi) :: j
6951 INTEGER(mpi) :: jgrp
6952 INTEGER(mpi) :: lgrp
6953 INTEGER(mpi) :: mqi
6954 INTEGER(mpi) :: nc31
6955 INTEGER(mpi) :: nr
6956 INTEGER(mpi) :: nwrd
6957 INTEGER(mpi) :: inone
6958 REAL(mpd) :: param
6959 REAL(mpd) :: presg
6960 REAL(mpd) :: prewt
6961
6962 INTEGER(mpl) :: length
6963 INTEGER(mpl) :: rows
6964 SAVE
6965 ! ...
6966 WRITE(lunlog,*) ' '
6967 WRITE(lunlog,*) 'LOOP1: starting'
6968 CALL mstart('LOOP1')
6969
6970 ! add labels from parameter, constraints, measurements, comments -------------
6971 DO i=1, lenparameters
6972 idum=inone(listparameters(i)%label)
6973 END DO
6974 DO i=1, lenpresigmas
6975 idum=inone(listpresigmas(i)%label)
6976 END DO
6977 DO i=1, lenconstraints
6978 idum=inone(listconstraints(i)%label)
6979 END DO
6980 DO i=1, lenmeasurements
6981 idum=inone(listmeasurements(i)%label)
6982 END DO
6983 DO i=1, lencomments
6984 idum=inone(listcomments(i)%label)
6985 END DO
6986
6987 IF(globalparheader(-1) /= 0) THEN
6988 WRITE(lunlog,*) 'LOOP1:',globalparheader(-1), ' labels from txt data stored'
6989 END IF
6990 WRITE(lunlog,*) 'LOOP1: reading data files'
6991
6992 neqn=0 ! number of equations
6993 negb=0 ! number of equations with global parameters
6994 ndgb=0 ! number of global derivatives
6995 nzgb=0 ! number of zero global derivatives
6996 DO
6997 DO j=1,globalparheader(-1)
6998 globalparlabelindex(2,j)=0 ! reset count
6999 END DO
7000
7001 ! read all data files and add all labels to global labels table ----
7002
7003 IF(mprint /= 0) THEN
7004 WRITE(*,*) 'Read all binary data files:'
7005 END IF
7006 CALL hmpldf(1,'Number of words/record in binary file')
7007 CALL hmpdef(8,0.0,60.0,'not_stored data per record')
7008 ! define read buffer
7009 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7010 nwrd=nc31+1
7011 length=nwrd*mthrdr
7012 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7013 nwrd=nc31*10+2+ndimbuf
7014 length=nwrd*mthrdr
7015 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7016 CALL mpalloc(readbufferdatad,length,'read buffer, double')
7017 ! to read (old) float binary files
7018 length=(ndimbuf+2)*mthrdr
7019 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7020
7021 DO
7022 CALL peread(nr) ! read records
7023 IF (skippedrecords == 0) THEN
7024 CALL peprep(0) ! prepare records
7025 CALL pepgrp ! update parameter group info
7026 END IF
7027 IF(nr <= 0) EXIT ! end of data?
7028 END DO
7029 ! release read buffer
7034 IF (skippedrecords == 0) THEN
7035 EXIT
7036 ELSE
7037 WRITE(lunlog,*) 'LOOP1: reading data files again'
7038 END IF
7039 END DO
7040
7041 IF(nhistp /= 0) THEN
7042 CALL hmprnt(1)
7043 CALL hmprnt(8)
7044 END IF
7045 CALL hmpwrt(1)
7046 CALL hmpwrt(8)
7047 ntgb = globalparheader(-1) ! total number of labels/parameters
7048 IF (ntgb == 0) THEN
7049 CALL peend(21,'Aborted, no labels/parameters defined')
7050 stop 'LOOP1: no labels/parameters defined'
7051 END IF
7052 CALL upone ! finalize the global label table
7053
7054 WRITE(lunlog,*) 'LOOP1:',ntgb, &
7055 ' is total number NTGB of labels/parameters'
7056 ! histogram number of entries per label ----------------------------
7057 CALL hmpldf(2,'Number of entries per label')
7058 DO j=1,ntgb
7059 CALL hmplnt(2,globalparlabelindex(2,j))
7060 END DO
7061 IF(nhistp /= 0) CALL hmprnt(2) ! print histogram
7062 CALL hmpwrt(2) ! write to his file
7063
7064 ! three subarrays for all global parameters ------------------------
7065 length=ntgb
7066 CALL mpalloc(globalparameter,length,'global parameters')
7067 globalparameter=0.0_mpd
7068 CALL mpalloc(globalparpresigma,length,'pre-sigmas') ! presigmas
7070 CALL mpalloc(globalparstart,length,'global parameters at start')
7072 CALL mpalloc(globalparcopy,length,'copy of global parameters')
7073 CALL mpalloc(globalparcons,length,'global parameter constraints')
7075 CALL mpalloc(globalparcomments,length,'global parameter comments')
7077
7078 DO i=1,lenparameters ! parameter start values
7079 param=listparameters(i)%value
7080 in=inone(listparameters(i)%label)
7081 IF(in /= 0) THEN
7082 globalparameter(in)=param
7083 globalparstart(in)=param
7084 ENDIF
7085 END DO
7086
7087 DO i=1, lencomments
7088 in=inone(listcomments(i)%label)
7089 IF(in /= 0) globalparcomments(in)=i
7090 END DO
7091
7092 npresg=0
7093 DO i=1,lenpresigmas ! pre-sigma values
7094 presg=listpresigmas(i)%value
7095 in=inone(listpresigmas(i)%label)
7096 IF(in /= 0) THEN
7097 IF(presg > 0.0) npresg=npresg+1 ! FIXME: check if enough 'entries'?
7098 globalparpresigma(in)=presg ! insert pre-sigma 0 or > 0
7099 END IF
7100 END DO
7101 WRITE(lunlog,*) 'LOOP1:',npresg,' is number of pre-sigmas'
7102 WRITE(*,*) 'LOOP1:',npresg,' is number of pre-sigmas'
7103 IF(npresg == 0) WRITE(*,*) 'Warning: no pre-sigmas defined'
7104
7105 ! build constraint groups, check for redundancy constrints
7106 CALL grpcon
7107
7108 ! determine flag variable (active) or fixed (inactive) -------------
7109
7110 indab=0
7111 DO i=1,ntgb
7112 IF (globalparpresigma(i) < 0.0) THEN
7113 globalparlabelindex(2,i)=-1 ! fixed (pre-sigma), not used in matrix (not active)
7114 ELSE IF(globalparlabelcounter(i) < mreqenf) THEN
7115 globalparlabelindex(2,i)=-2 ! fixed (entries cut), not used in matrix (not active)
7116 ELSE IF (globalparcons(i) < 0) THEN
7117 globalparlabelindex(2,i)=-4 ! fixed (redundant), not used in matrix (not active)
7118 ELSE
7119 indab=indab+1
7120 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
7121 END IF
7122 END DO
7123 globalparheader(-6)=indab ! counted variable
7124 nvgb=indab ! nr of variable parameters
7125 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7126 IF(iteren > mreqenf) THEN
7127 IF (mcount == 0) THEN
7128 CALL loop1i ! iterate entries cut
7129 ELSE
7130 WRITE(lunlog,*) 'LOOP1: counting records, NO iteration of entries cut !'
7131 iteren=0
7132 END IF
7133 END IF
7134
7135 ! --- check for parameter groups
7136 CALL hmpdef(15,0.0,120.0,'Number of parameters per group')
7137 ntpgrp=0
7138 DO j=1,ntgb
7139 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7140 ! new group?
7142 globalparlabelindex(4,j)=ntpgrp ! relation total index -> group
7143 END DO
7144 ! check variable parameters
7145 nvpgrp=0
7146 lgrp=-1
7147 DO j=1,ntgb
7148 IF (globalparlabelindex(2,j) <= 0) cycle ! skip fixed parameter
7149 ! new group ?
7150 IF (globalparlabelindex(4,j) /= lgrp) nvpgrp=nvpgrp+1
7151 lgrp=globalparlabelindex(4,j)
7152 END DO
7153 length=ntpgrp; rows=2
7154 CALL mpalloc(globaltotindexgroups,rows,length,'parameter groups, 1. index and size')
7156 ! fill
7157 lgrp=-1
7158 DO j=1,ntgb
7159 IF (globalparlabelindex(3,j) == 0) cycle ! skip empty parameter
7160 jgrp=globalparlabelindex(4,j)
7161 IF (jgrp /= lgrp) globaltotindexgroups(1,jgrp)=j ! first (total) index
7162 globaltotindexgroups(2,jgrp)=globaltotindexgroups(2,jgrp)+1 ! (total) size
7163 lgrp=jgrp
7164 END DO
7165 DO j=1,ntpgrp
7166 CALL hmpent(15,real(globaltotindexgroups(2,j),mps))
7167 END DO
7168 IF(nhistp /= 0) CALL hmprnt(15) ! print histogram
7169 CALL hmpwrt(15) ! write to his file
7170 WRITE(lunlog,*) 'LOOP1:',ntpgrp, &
7171 ' is total number NTPGRP of label/parameter groups'
7172 !print *, ' globalTotIndexGroups ', globalTotIndexGroups
7173
7174 ! translation table of length NVGB of total global indices ---------
7175 length=nvgb
7176 CALL mpalloc(globalparvartototal,length,'translation table var -> total')
7177 indab=0
7178 DO i=1,ntgb
7179 IF(globalparlabelindex(2,i) > 0) THEN
7180 indab=indab+1
7181 globalparvartototal(indab)=i
7182 END IF
7183 END DO
7184
7185 ! regularization ---------------------------------------------------
7186 CALL mpalloc(globalparpreweight,length,'pre-sigmas weights') ! presigma weights
7187 WRITE(*,112) ' Default pre-sigma =',regpre, &
7188 ' (if no individual pre-sigma defined)'
7189 WRITE(*,*) 'Pre-sigma factor is',regula
7190
7191 IF(nregul == 0) THEN
7192 WRITE(*,*) 'No regularization will be done'
7193 ELSE
7194 WRITE(*,*) 'Regularization will be done, using factor',regula
7195 END IF
7196112 FORMAT(a,e9.2,a)
7197 IF (nvgb <= 0) THEN
7198 CALL peend(22,'Aborted, no variable global parameters')
7199 stop '... no variable global parameters'
7200 ENDIF
7201
7202 DO ivgbi=1,nvgb ! IVGBI = index of variable global parameter
7203 itgbi=globalparvartototal(ivgbi) ! ITGBI = global parameter index
7204 presg=globalparpresigma(itgbi) ! get pre-sigma
7205 prewt=0.0 ! pre-weight
7206 IF(presg > 0.0) THEN
7207 prewt=1.0/presg**2 ! 1/presigma^2
7208 ELSE IF(presg == 0.0.AND.regpre > 0.0) THEN
7209 prewt=1.0/real(regpre**2,mpd) ! default 1/presigma^2
7210 END IF
7211 globalparpreweight(ivgbi)=regula*prewt ! weight = factor / presigma^2
7212 END DO
7213
7214 ! WRITE(*,*) 'GlPa_index GlPa_label array1 array6'
7215 DO i=1,ntgb
7216 itgbl=globalparlabelindex(1,i)
7217 ivgbi=globalparlabelindex(2,i)
7218 IF(ivgbi > 0) THEN
7219 ! WRITE(*,111) I,ITGBL,QM(IND1+I),QM(IND6+IVGBI)
7220 ELSE
7221 ! WRITE(*,111) I,ITGBL,QM(IND1+I)
7222 END IF
7223 END DO
7224 ! 111 FORMAT(I5,I10,F10.5,E12.4)
7225 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7226 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7227 ! To avoid INT(mpi) overflows in diagonalization
7228 IF (metsol == 2.AND.nvgb >= 46340) THEN
7229 metsol=1
7230 WRITE(*,101) 'Too many variable parameters for diagonalization, fallback is inversion'
7231 END IF
7232
7233 ! print overview over important numbers ----------------------------
7234
7235 nrecal=nrec
7236 IF(mprint /= 0) THEN
7237 WRITE(*,*) ' '
7238 WRITE(*,101) ' NREC',nrec,'number of records'
7239 IF (nrecd > 0) WRITE(*,101) ' NRECD',nrec,'number of records containing doubles'
7240 WRITE(*,101) ' NEQN',neqn,'number of equations (measurements)'
7241 WRITE(*,101) ' NEGB',negb,'number of equations with global parameters'
7242 WRITE(*,101) ' NDGB',ndgb,'number of global derivatives'
7243 IF (nzgb > 0) THEN
7244 WRITE(*,101) ' NZGB',nzgb,'number of zero global der. (ignored in entry counts)'
7245 ENDIF
7246 IF (mcount == 0) THEN
7247 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7248 ELSE
7249 WRITE(*,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7250 ENDIF
7251 IF(iteren > mreqenf) &
7252 WRITE(*,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7253 WRITE(*,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7254 IF (mreqpe > 1) WRITE(*,101) &
7255 'MREQPE',mreqpe,'required number of pair entries'
7256 IF (msngpe >= 1) WRITE(*,101) &
7257 'MSNGPE',msngpe,'max pair entries single prec. storage'
7258 WRITE(*,101) 'NTGB',ntgb,'total number of parameters'
7259 WRITE(*,101) 'NVGB',nvgb,'number of variable parameters'
7260 IF(mprint > 1) THEN
7261 WRITE(*,*) ' '
7262 WRITE(*,*) 'Global parameter labels:'
7263 mqi=ntgb
7264 IF(mqi <= 100) THEN
7265 WRITE(*,*) (globalparlabelindex(2,i),i=1,mqi)
7266 ELSE
7267 WRITE(*,*) (globalparlabelindex(2,i),i=1,30)
7268 WRITE(*,*) ' ...'
7269 mqi=((mqi-20)/20)*20+1
7270 WRITE(*,*) (globalparlabelindex(2,i),i=mqi,ntgb)
7271 END IF
7272 END IF
7273 WRITE(*,*) ' '
7274 WRITE(*,*) ' '
7275 END IF
7276 WRITE(8,*) ' '
7277 WRITE(8,101) ' NREC',nrec,'number of records'
7278 IF (nrecd > 0) WRITE(8,101) ' NRECD',nrec,'number of records containing doubles'
7279 WRITE(8,101) ' NEQN',neqn,'number of equations (measurements)'
7280 WRITE(8,101) ' NEGB',negb,'number of equations with global parameters'
7281 WRITE(8,101) ' NDGB',ndgb,'number of global derivatives'
7282 IF (mcount == 0) THEN
7283 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (eqns in binary files)'
7284 ELSE
7285 WRITE(8,101) 'MREQENF',mreqenf,'required number of entries (recs in binary files)'
7286 ENDIF
7287 IF(iteren > mreqenf) &
7288 WRITE(8,101) 'ITEREN',iteren,'iterate cut for parameters with less entries'
7289 WRITE(8,101) 'MREQENA',mreqena,'required number of entries (from accepted fits)'
7290
7291 WRITE(lunlog,*) 'LOOP1: ending'
7292 WRITE(lunlog,*) ' '
7293 CALL mend
7294
7295101 FORMAT(1x,a8,' =',i14,' = ',a)
7296END SUBROUTINE loop1
7297
7305SUBROUTINE loop1i
7306 USE mpmod
7307 USE mpdalc
7308
7309 IMPLICIT NONE
7310 INTEGER(mpi) :: i
7311 INTEGER(mpi) :: ibuf
7312 INTEGER(mpi) :: ij
7313 INTEGER(mpi) :: indab
7314 INTEGER(mpi) :: ist
7315 INTEGER(mpi) :: j
7316 INTEGER(mpi) :: ja
7317 INTEGER(mpi) :: jb
7318 INTEGER(mpi) :: jsp
7319 INTEGER(mpi) :: nc31
7320 INTEGER(mpi) :: nr
7321 INTEGER(mpi) :: nlow
7322 INTEGER(mpi) :: nst
7323 INTEGER(mpi) :: nwrd
7324
7325 INTEGER(mpl) :: length
7326 INTEGER(mpl), DIMENSION(:), ALLOCATABLE :: newCounter
7327 SAVE
7328
7329 ! ...
7330 WRITE(lunlog,*) ' '
7331 WRITE(lunlog,*) 'LOOP1: iterating'
7332 WRITE(*,*) ' '
7333 WRITE(*,*) 'LOOP1: iterating'
7334
7335 length=ntgb
7336 CALL mpalloc(newcounter,length,'new entries counter')
7337 newcounter=0
7338
7339 ! define read buffer
7340 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7341 nwrd=nc31+1
7342 length=nwrd*mthrdr
7343 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7344 nwrd=nc31*10+2+ndimbuf
7345 length=nwrd*mthrdr
7346 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7347 CALL mpalloc(readbufferdatad,length,'read buffer, double')
7348 ! to read (old) float binary files
7349 length=(ndimbuf+2)*mthrdr
7350 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7351
7352 DO
7353 CALL peread(nr) ! read records
7354 CALL peprep(1) ! prepare records
7355 DO ibuf=1,numreadbuffer ! buffer for current record
7356 ist=readbufferpointer(ibuf)+1
7358 nwrd=nst-ist+1
7359 DO ! loop over measurements
7360 CALL isjajb(nst,ist,ja,jb,jsp)
7361 IF(ja == 0.AND.jb == 0) EXIT
7362 IF(ja /= 0) THEN
7363 nlow=0
7364 DO j=1,ist-jb
7365 ij=readbufferdatai(jb+j) ! index of global parameter
7366 ij=globalparlabelindex(2,ij) ! change to variable parameter
7367 IF(ij == -2) nlow=nlow+1 ! fixed by entries cut
7368 END DO
7369 IF(nlow == 0) THEN
7370 DO j=1,ist-jb
7371 ij=readbufferdatai(jb+j) ! index of global parameter
7372 newcounter(ij)=newcounter(ij)+1 ! count again
7373 END DO
7374 ENDIF
7375 END IF
7376 END DO
7377 ! end-of-event
7378 END DO
7379 IF(nr <= 0) EXIT ! end of data?
7380 END DO
7381
7382 ! release read buffer
7387
7388 indab=0
7389 DO i=1,ntgb
7390 IF(globalparlabelindex(2,i) > 0) THEN
7391 IF(newcounter(i) >= mreqenf .OR. globalparlabelcounter(i) >= iteren) THEN
7392 indab=indab+1
7393 globalparlabelindex(2,i)=indab ! variable, used in matrix (active)
7394 ELSE
7395 globalparlabelindex(2,i)=-3 ! fixed (iterated entries cut), not used in matrix (not active)
7396 END IF
7397 END IF
7398 END DO
7399 globalparheader(-6)=indab ! counted variable
7400 nvgb=indab ! nr of variable parameters
7401 WRITE(lunlog,*) 'LOOP1:',nvgb, ' is number NVGB of variable parameters'
7402 CALL mpdealloc(newcounter)
7403
7404END SUBROUTINE loop1i
7405
7416
7417SUBROUTINE loop2
7418 USE mpmod
7419 USE mpdalc
7420
7421 IMPLICIT NONE
7422 REAL(mps) :: chin2
7423 REAL(mps) :: chin3
7424 REAL(mps) :: cpr
7425 REAL(mps) :: fsum
7426 REAL(mps) :: gbc
7427 REAL(mps) :: gbu
7428 INTEGER(mpi) :: i
7429 INTEGER(mpi) :: ia
7430 INTEGER(mpi) :: ib
7431 INTEGER(mpi) :: ibuf
7432 INTEGER(mpi) :: icblst
7433 INTEGER(mpi) :: icboff
7434 INTEGER(mpi) :: icgb
7435 INTEGER(mpi) :: icgrp
7436 INTEGER(mpi) :: icount
7437 INTEGER(mpi) :: iext
7438 INTEGER(mpi) :: ihis
7439 INTEGER(mpi) :: ij
7440 INTEGER(mpi) :: ij1
7441 INTEGER(mpi) :: ijn
7442 INTEGER(mpi) :: ioff
7443 INTEGER(mpi) :: ipoff
7444 INTEGER(mpi) :: iproc
7445 INTEGER(mpi) :: irecmm
7446 INTEGER(mpi) :: ist
7447 INTEGER(mpi) :: itgbi
7448 INTEGER(mpi) :: itgbij
7449 INTEGER(mpi) :: itgbik
7450 INTEGER(mpi) :: ivgbij
7451 INTEGER(mpi) :: ivgbik
7452 INTEGER(mpi) :: ivpgrp
7453 INTEGER(mpi) :: j
7454 INTEGER(mpi) :: ja
7455 INTEGER(mpi) :: jb
7456 INTEGER(mpi) :: jcgrp
7457 INTEGER(mpi) :: jext
7458 INTEGER(mpi) :: jcgb
7459 INTEGER(mpi) :: jrec
7460 INTEGER(mpi) :: jsp
7461 INTEGER(mpi) :: joff
7462 INTEGER(mpi) :: k
7463 INTEGER(mpi) :: kcgrp
7464 INTEGER(mpi) :: kfile
7465 INTEGER(mpi) :: l
7466 INTEGER(mpi) :: label
7467 INTEGER(mpi) :: labelf
7468 INTEGER(mpi) :: labell
7469 INTEGER(mpi) :: lvpgrp
7470 INTEGER(mpi) :: lu
7471 INTEGER(mpi) :: lun
7472 INTEGER(mpi) :: maeqnf
7473 INTEGER(mpi) :: nall
7474 INTEGER(mpi) :: naeqna
7475 INTEGER(mpi) :: naeqnf
7476 INTEGER(mpi) :: naeqng
7477 INTEGER(mpi) :: npdblk
7478 INTEGER(mpi) :: nc31
7479 INTEGER(mpi) :: ncachd
7480 INTEGER(mpi) :: ncachi
7481 INTEGER(mpi) :: ncachr
7482 INTEGER(mpi) :: ncon
7483 INTEGER(mpi) :: nda
7484 INTEGER(mpi) :: ndf
7485 INTEGER(mpi) :: ndfmax
7486 INTEGER(mpi) :: nfixed
7487 INTEGER(mpi) :: nggd
7488 INTEGER(mpi) :: nggi
7489 INTEGER(mpi) :: nmatmo
7490 INTEGER(mpi) :: noff
7491 INTEGER(mpi) :: npair
7492 INTEGER(mpi) :: npar
7493 INTEGER(mpi) :: nparmx
7494 INTEGER(mpi) :: nr
7495 INTEGER(mpi) :: nrece
7496 INTEGER(mpi) :: nrecf
7497 INTEGER(mpi) :: nrecmm
7498 INTEGER(mpi) :: nst
7499 INTEGER(mpi) :: nwrd
7500 INTEGER(mpi) :: inone
7501 INTEGER(mpi) :: inc
7502 REAL(mps) :: wgh
7503 REAL(mps) :: wolfc3
7504 REAL(mps) :: wrec
7505 REAL(mps) :: chindl
7506
7507 REAL(mpd)::dstat(3)
7508 REAL(mpd)::rerr
7509 INTEGER(mpl):: nblock
7510 INTEGER(mpl):: nbwrds
7511 INTEGER(mpl):: noff8
7512 INTEGER(mpl):: ndimbi
7513 INTEGER(mpl):: ndimsa(4)
7514 INTEGER(mpl):: ndgn
7515 INTEGER(mpl):: nnzero
7516 INTEGER(mpl):: matsiz(2)
7517 INTEGER(mpl):: matwords
7518 INTEGER(mpl):: mbwrds
7519 INTEGER(mpl):: length
7520 INTEGER(mpl):: rows
7521 INTEGER(mpl):: cols
7522 INTEGER(mpl), PARAMETER :: two=2
7523 INTEGER(mpi) :: maxGlobalPar = 0
7524 INTEGER(mpi) :: maxLocalPar = 0
7525 INTEGER(mpi) :: maxEquations = 0
7526
7527 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupList
7528 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecConsGroupIndex
7529 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecPairedParGroups
7530 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: vecBlockCounts
7531
7532 INTERFACE ! needed for assumed-shape dummy arguments
7533 SUBROUTINE ndbits(npgrp,ndims,nsparr,ihst)
7534 USE mpdef
7535 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7536 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7537 INTEGER(mpl), DIMENSION(:,:), INTENT(OUT) :: nsparr
7538 INTEGER(mpi), INTENT(IN) :: ihst
7539 END SUBROUTINE ndbits
7540 SUBROUTINE ckbits(npgrp,ndims)
7541 USE mpdef
7542 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7543 INTEGER(mpl), DIMENSION(4), INTENT(OUT) :: ndims
7544 END SUBROUTINE ckbits
7545 SUBROUTINE spbits(npgrp,nsparr,nsparc)
7546 USE mpdef
7547 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7548 INTEGER(mpl), DIMENSION(:,:), INTENT(IN) :: nsparr
7549 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: nsparc
7550 END SUBROUTINE spbits
7551 SUBROUTINE gpbmap(ngroup,npgrp,npair)
7552 USE mpdef
7553 INTEGER(mpi), INTENT(IN) :: ngroup
7554 INTEGER(mpi), DIMENSION(:,:), INTENT(IN) :: npgrp
7555 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npair
7556 END SUBROUTINE gpbmap
7557 SUBROUTINE ggbmap(ipgrp,npair,npgrp)
7558 USE mpdef
7559 INTEGER(mpi), INTENT(IN) :: ipgrp
7560 INTEGER(mpi), INTENT(OUT) :: npair
7561 INTEGER(mpi), DIMENSION(:), INTENT(OUT) :: npgrp
7562 END SUBROUTINE ggbmap
7563 SUBROUTINE pbsbits(npgrp,ibsize,nnzero,nblock,nbkrow)
7564 USE mpdef
7565 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7566 INTEGER(mpi), INTENT(IN) :: ibsize
7567 INTEGER(mpl), INTENT(OUT) :: nnzero
7568 INTEGER(mpl), INTENT(OUT) :: nblock
7569 INTEGER(mpi), DIMENSION(:),INTENT(OUT) :: nbkrow
7570 END SUBROUTINE pbsbits
7571 SUBROUTINE pblbits(npgrp,ibsize,nsparr,nsparc)
7572 USE mpdef
7573 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7574 INTEGER(mpi), INTENT(IN) :: ibsize
7575 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7576 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7577 END SUBROUTINE pblbits
7578 SUBROUTINE prbits(npgrp,nsparr)
7579 USE mpdef
7580 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7581 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparr
7582 END SUBROUTINE prbits
7583 SUBROUTINE pcbits(npgrp,nsparr,nsparc)
7584 USE mpdef
7585 INTEGER(mpi), DIMENSION(:), INTENT(IN) :: npgrp
7586 INTEGER(mpl), DIMENSION(:), INTENT(IN) :: nsparr
7587 INTEGER(mpl), DIMENSION(:), INTENT(OUT) :: nsparc
7588 END SUBROUTINE pcbits
7589 END INTERFACE
7590
7591 SAVE
7592
7593 !$ INTEGER(mpi) :: OMP_GET_THREAD_NUM
7594
7595 ! ...
7596 WRITE(lunlog,*) ' '
7597 WRITE(lunlog,*) 'LOOP2: starting'
7598 CALL mstart('LOOP2')
7599
7600 ! two subarrays to get the global parameter indices, used in an event
7601 length=nvgb
7602 CALL mpalloc(globalindexusage,length,'global index')
7603 CALL mpalloc(backindexusage,length,'back index')
7605 CALL mpalloc(globalindexranges,length,'global index ranges')
7607
7608 length=ntgb
7609 CALL mpalloc(globalparlabelzeros,length,'global label with zero der. counters')
7611
7612 ! prepare constraints - determine number of constraints NCGB
7613 ! - sort and split into blocks
7614 ! - update globalIndexRanges
7615 CALL prpcon
7616
7617 IF (metsol == 3.AND.icelim <= 0) THEN
7618 ! decomposition: enforce elimination
7619 icelim=1
7620 WRITE(lunlog,*) ' Elimination for constraints enforced for solution by decomposition!'
7621 END IF
7622 IF (metsol == 9.AND.icelim > 0) THEN
7623 ! sparsePARDISO: enforce multipliers
7624 icelim=0
7625 WRITE(lunlog,*) ' Lagrange multipliers enforced for solution by sparsePARDISO!'
7626 END IF
7627 IF (matsto > 0.AND.icelim > 1) THEN
7628 ! decomposition: enforce elimination
7629 icelim=1
7630 WRITE(lunlog,*) ' Elimination for constraints with mpqldec enforced (LAPACK only for unpacked storage)!'
7631 END IF
7632 IF (icelim > 0) THEN ! elimination
7633 nagb=nvgb ! total number of parameters
7634 napgrp=nvpgrp ! total number of parameter groups
7635 nfgb=nvgb-ncgb ! number of fit parameters
7636 nprecond(1)=0 ! number of constraints for preconditioner
7637 nprecond(2)=nfgb ! matrix size for preconditioner
7638 nprecond(3)=0 ! number of constraint blocks for preconditioner
7639 ELSE ! Lagrange multipliers
7640 nagb=nvgb+ncgb ! total number of parameters
7641 napgrp=nvpgrp+ncgb ! total number of parameter groups
7642 nfgb=nagb ! number of fit parameters
7643 nprecond(1)=ncgb ! number of constraints for preconditioner
7644 nprecond(2)=nvgb ! matrix size for preconditioner
7645 nprecond(3)=ncblck ! number of constraint blocks for preconditioner
7646 ENDIF
7647 noff8=int(nagb,mpl)*int(nagb-1,mpl)/2
7648
7649 ! all (variable) parameter groups
7650 length=napgrp+1
7651 CALL mpalloc(globalallindexgroups,length,'all parameter groups, 1. index')
7653 ivpgrp=0
7654 lvpgrp=-1
7655 DO i=1,ntgb
7656 ij=globalparlabelindex(2,i)
7657 IF (ij <= 0) cycle ! variable ?
7658 IF (globalparlabelindex(4,i) /= lvpgrp) THEN
7659 ivpgrp=ivpgrp+1
7660 globalallindexgroups(ivpgrp)=ij ! first index
7661 lvpgrp=globalparlabelindex(4,i)
7662 END IF
7663 END DO
7664 ! Lagrange multipliers
7665 IF (napgrp > nvpgrp) THEN
7666 DO jcgb=1, ncgb
7667 ivpgrp=ivpgrp+1
7668 globalallindexgroups(ivpgrp)=nvgb+jcgb
7669 END DO
7670 END IF
7672 ! from all (variable) parameters to group
7673 length=nagb
7674 CALL mpalloc(globalallpartogroup,length,'translation table all (var) par -> group')
7676 DO i=1,napgrp
7679 END DO
7680 END DO
7681 IF (icheck > 2) THEN
7682 print *
7683 print *, ' Variable parameter groups ', nvpgrp
7684 DO i=1,nvpgrp
7686 k=globalparlabelindex(4,itgbi) ! (total) group index
7688 globalparlabelindex(1,itgbi)
7689 END DO
7690 print *
7691 END IF
7692
7693 ! read all data files and add all variable index pairs -------------
7694
7695 IF (icheck > 1) CALL clbmap(ntpgrp+ncgrp)
7696
7697 IF(matsto == 2) THEN
7698 ! MINRES, sparse storage
7699 CALL clbits(napgrp,mreqpe,mhispe,msngpe,mextnd,ndimbi,nspc) ! get dimension for bit storage, encoding, precision info
7700 END IF
7701 IF(matsto == 3) THEN
7702 ! PARDISO, upper triangle (parameter groups) incl. rectangular part (constraints)
7703 CALL plbits(nvpgrp,nvgb,ncgb,ndimbi) ! get dimension for bit storage, global parameters and constraints
7704 END IF
7705
7706 IF (imonit /= 0) THEN
7707 length=ntgb
7708 CALL mpalloc(measindex,length,'measurement counter/index')
7709 measindex=0
7710 CALL mpalloc(measres,length,'measurement resolution')
7711 measres=0.0_mps
7712 lunmon=9
7713 CALL mvopen(lunmon,'millepede.mon')
7714 ENDIF
7715
7716 ! for checking appearance
7717 IF (icheck > 1) THEN
7718 length=5*(ntgb+ncgrp)
7719 CALL mpalloc(appearancecounter,length,'appearance statistics')
7721 length=ntgb
7722 CALL mpalloc(paircounter,length,'pair statistics')
7723 paircounter=0
7724 END IF
7725
7726 ! checking constraint goups
7727 IF (icheck > 0.AND. ncgrp > 0) THEN
7728 length=ncgrp
7729 CALL mpalloc(vecconsgroupcounts,length,'counter for constraint groups')
7731 CALL mpalloc(vecconsgrouplist,length,'constraint group list')
7732 CALL mpalloc(vecconsgroupindex,length,'constraint group index')
7733 vecconsgroupindex=0
7734 END IF
7735
7736 ! reading events===reading events===reading events===reading events=
7737 nrece =0 ! 'empty' records (no variable global parameters)
7738 nrecf =0 ! records with fixed global parameters
7739 naeqng=0 ! count number of equations (with global der.)
7740 naeqnf=0 ! count number of equations ( " , fixed)
7741 naeqna=0 ! all
7742 WRITE(lunlog,*) 'LOOP2: start event reading'
7743 ! monitoring for sparse matrix?
7744 irecmm=0
7745 IF (matsto == 2.AND.matmon /= 0) THEN
7746 nmatmo=0
7747 IF (matmon > 0) THEN
7748 nrecmm=matmon
7749 ELSE
7750 nrecmm=1
7751 END IF
7752 END IF
7753 DO k=1,3
7754 dstat(k)=0.0_mpd
7755 END DO
7756 ! define read buffer
7757 nc31=ncache/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
7758 nwrd=nc31+1
7759 length=nwrd*mthrdr
7760 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
7761 nwrd=nc31*10+2+ndimbuf
7762 length=nwrd*mthrdr
7763 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
7764 CALL mpalloc(readbufferdatad,length,'read buffer, real')
7765 ! to read (old) float binary files
7766 length=(ndimbuf+2)*mthrdr
7767 CALL mpalloc(readbufferdataf,length,'read buffer, float')
7768
7769 DO
7770 CALL peread(nr) ! read records
7771 CALL peprep(1) ! prepare records
7772 ioff=0
7773 DO ibuf=1,numreadbuffer ! buffer for current record
7774 jrec=readbufferdatai(readbufferpointer(ibuf)-1) ! record number in file
7775 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7776 nrec=ifd(kfile)+jrec ! global record number
7777 ! Printout for DEBUG
7778 IF(nrec <= mdebug) THEN
7779 nda=0
7780 wrec =real(readbufferdatad(readbufferpointer(ibuf)-1),mps) ! weight
7781 WRITE(*,*) ' '
7782 WRITE(*,*) 'Record number ',nrec,' from file ',kfile
7783 IF (wgh /= 1.0) WRITE(*,*) ' weight ',wrec
7784 ist=readbufferpointer(ibuf)+1
7786 DO ! loop over measurements
7787 CALL isjajb(nst,ist,ja,jb,jsp)
7788 IF(ja == 0) EXIT
7789 nda=nda+1
7790 IF(nda > mdebg2) THEN
7791 IF(nda == mdebg2+1) WRITE(*,*) '... and more data'
7792 cycle
7793 END IF
7794 WRITE(*,*) ' '
7795 WRITE(*,*) nda, ' Measured value =',readbufferdatad(ja),' +- ',readbufferdatad(jb)
7796 WRITE(*,*) 'Local derivatives:'
7797 WRITE(*,107) (readbufferdatai(ja+j),readbufferdatad(ja+j),j=1,jb-ja-1)
7798107 FORMAT(6(i3,g12.4))
7799 IF (jb < ist) THEN
7800 WRITE(*,*) 'Global derivatives:'
7801 WRITE(*,108) (globalparlabelindex(1,readbufferdatai(jb+j)),readbufferdatai(jb+j), &
7802 globalparlabelindex(2,readbufferdatai(jb+j)),readbufferdatad(jb+j),j=1,ist-jb)
7803108 FORMAT(3i11,g12.4)
7804 END IF
7805 IF(nda == 1) THEN
7806 WRITE(*,*) 'total_par_label __label__ var_par_index derivative'
7807 END IF
7808 END DO
7809 WRITE(*,*) ' '
7810 END IF
7811
7812 nagbn =0 ! count number of global derivatives
7813 nalcn =0 ! count number of local derivatives
7814 naeqn =0 ! count number of equations
7815 icgrp =0 ! count constraint groups
7816 maeqnf=naeqnf
7817 ist=readbufferpointer(ibuf)+1
7819 nwrd=nst-ist+1
7820 DO ! loop over measurements
7821 CALL isjajb(nst,ist,ja,jb,jsp)
7822 IF(ja == 0.AND.jb == 0) EXIT
7823 naeqn=naeqn+1
7824 naeqna=naeqna+1
7825 IF(ja /= 0) THEN
7826 IF (ist > jb) THEN
7827 naeqng=naeqng+1
7828 ! monitoring, group measurements, sum up entries and errors
7829 IF (imonit /= 0) THEN
7830 rerr =real(readbufferdatad(jb),mpd) ! the error
7831 ij=readbufferdatai(jb+1) ! index of first global parameter, used to group measurements
7832 measindex(ij)=measindex(ij)+1
7833 measres(ij)=measres(ij)+rerr
7834 END IF
7835 END IF
7836 nfixed=0
7837 DO j=1,ist-jb
7838 ij=readbufferdatai(jb+j) ! index of global parameter
7839 IF (nzgb > 0) THEN
7840 ! count zero global derivatives
7841 IF (readbufferdatad(jb+j) == 0.0_mpl) globalparlabelzeros(ij)=globalparlabelzeros(ij)+1
7842 END IF
7843 ! check appearance
7844 IF (icheck > 1) THEN
7845 joff = 5*(ij-1)
7846 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7847 IF (appearancecounter(joff+1) == 0) THEN
7848 appearancecounter(joff+1) = kfile
7849 appearancecounter(joff+2) = jrec ! (local) record number
7850 END IF
7851 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=appearancecounter(joff+5)+1
7852 appearancecounter(joff+3) = kfile
7853 appearancecounter(joff+4) = jrec ! (local) record number
7854 ! count pairs
7855 DO k=1,j
7857 END DO
7858 jcgrp=globalparcons(ij)
7859 ! correlate constraint groups with 'other' parameter groups
7860 DO k=1,j
7861 kcgrp=globalparcons(readbufferdatai(jb+k))
7862 IF (kcgrp == jcgrp) cycle
7863 IF (jcgrp > 0) CALL inbmap(ntpgrp+jcgrp,globalparlabelindex(4,readbufferdatai(jb+k)))
7864 IF (kcgrp > 0) CALL inbmap(ntpgrp+kcgrp,globalparlabelindex(4,ij))
7865 END DO
7866 END IF
7867 ! check constraint groups
7868 IF (icheck > 0.AND.ncgrp > 0) THEN
7869 k=globalparcons(ij) ! constraint group
7870 IF (k > 0) THEN
7871 icount=naeqn
7872 IF (mcount > 0) icount=1 ! count records
7873 IF (vecconsgroupindex(k) == 0) THEN
7874 ! add to list
7875 icgrp=icgrp+1
7876 vecconsgrouplist(icgrp)=k
7877 ! check appearance
7878 IF (icheck > 1) THEN
7879 joff = 5*(ntgb+k-1)
7880 kfile=nint(readbufferdatad(readbufferpointer(ibuf)),mpi) ! file
7881 IF (appearancecounter(joff+1) == 0) THEN
7882 appearancecounter(joff+1) = kfile
7883 appearancecounter(joff+2) = jrec ! (local) record number
7884 END IF
7885 IF (appearancecounter(joff+3) /= kfile) appearancecounter(joff+5)=&
7886 appearancecounter(joff+5)+1
7887 appearancecounter(joff+3) = kfile
7888 appearancecounter(joff+4) = jrec ! (local) record number
7889 END IF
7890 END IF
7891 IF (vecconsgroupindex(k) < icount) THEN
7892 ! count
7893 vecconsgroupindex(k)=icount
7895 END IF
7896 END IF
7897 END IF
7898
7899 ij=globalparlabelindex(2,ij) ! change to variable parameter
7900 IF(ij > 0) THEN
7901 ijn=backindexusage(ij) ! get index of index
7902 IF(ijn == 0) THEN ! not yet included
7903 nagbn=nagbn+1 ! count
7904 globalindexusage(nagbn)=ij ! store variable index
7905 backindexusage(ij)=nagbn ! store back index
7906 END IF
7907 ELSE
7908 nfixed=nfixed+1
7909 END IF
7910 END DO
7911 IF (nfixed > 0) naeqnf=naeqnf+1
7912 END IF
7913
7914 IF(ja /= 0.AND.jb /= 0) THEN
7915 DO j=1,jb-ja-1 ! local parameters
7916 ij=readbufferdatai(ja+j)
7917 nalcn=max(nalcn,ij)
7918 END DO
7919 END IF
7920 END DO
7921
7922 ! end-of-event
7923 IF (naeqnf > maeqnf) nrecf=nrecf+1
7924 irecmm=irecmm+1
7925 ! end-of-event-end-of-event-end-of-event-end-of-event-end-of-event-e
7926
7927 maxglobalpar=max(nagbn,maxglobalpar) ! maximum number of global parameters
7928 maxlocalpar=max(nalcn,maxlocalpar) ! maximum number of local parameters
7929 maxequations=max(naeqn,maxequations) ! maximum number of equations
7930
7931 ! sample statistics for caching
7932 dstat(1)=dstat(1)+real((nwrd+2)*2,mpd) ! record size
7933 dstat(2)=dstat(2)+real(nagbn+2,mpd) ! indices,
7934 dstat(3)=dstat(3)+real(nagbn*nagbn+nagbn,mpd) ! data for MUPDAT
7935
7936 ! clear constraint groups index
7937 DO k=1, icgrp
7938 vecconsgroupindex(vecconsgrouplist(k))=0
7939 END DO
7940
7941 CALL sort1k(globalindexusage,nagbn) ! sort global par.
7942
7943 IF (nagbn == 0) THEN
7944 nrece=nrece+1
7945 ELSE
7946 ! update parameter range
7949 ENDIF
7950
7951 ! overwrite read buffer with lists of global labels
7952 ioff=ioff+1
7953 readbufferpointer(ibuf)=ioff
7954 readbufferdatai(ioff)=ioff+nagbn
7955 joff=ioff
7956 lvpgrp=-1
7957 DO i=1,nagbn ! reset global index array, store parameter groups
7958 iext=globalindexusage(i)
7959 backindexusage(iext)=0
7960 ivpgrp=globalallpartogroup(iext)
7961 !ivpgrp=iext
7962 IF (ivpgrp /= lvpgrp) THEN
7963 joff=joff+1
7964 readbufferdatai(joff)=ivpgrp
7965 lvpgrp=ivpgrp
7966 END IF
7967 END DO
7968 readbufferdatai(ioff)=joff
7969 ioff=joff
7970
7971 END DO
7972 ioff=0
7973
7974 IF (matsto == 3) THEN
7975 !$OMP PARALLEL &
7976 !$OMP DEFAULT(PRIVATE) &
7977 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
7978 iproc=0
7979 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
7980 DO ibuf=1,numreadbuffer
7981 ist=readbufferpointer(ibuf)+1
7983 DO i=ist,nst ! store all combinations
7984 iext=readbufferdatai(i) ! variable global index
7985 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct column per thread
7986 DO l=i,nst
7987 jext=readbufferdatai(l)
7988 CALL inbits(iext,jext,1) ! save space
7989 END DO
7990 !$ ENDIF
7991 END DO
7992 END DO
7993 !$OMP END PARALLEL
7994 END IF
7995 IF (matsto == 2) THEN
7996 !$OMP PARALLEL &
7997 !$OMP DEFAULT(PRIVATE) &
7998 !$OMP SHARED(numReadBuffer,readBufferPointer,readBufferDataI,MTHRD)
7999 iproc=0
8000 !$ IPROC=OMP_GET_THREAD_NUM() ! thread number
8001 DO ibuf=1,numreadbuffer
8002 ist=readbufferpointer(ibuf)+1
8004 DO i=ist,nst ! store all combinations
8005 iext=readbufferdatai(i) ! variable global index
8006 !$ IF (MOD(IEXT,MTHRD).EQ.IPROC) THEN ! distinct rows per thread
8007 DO l=ist,i
8008 jext=readbufferdatai(l)
8009 CALL inbits(iext,jext,1) ! save space
8010 END DO
8011 !$ ENDIF
8012 END DO
8013 END DO
8014 !$OMP END PARALLEL
8015 ! monitoring
8016 IF (matmon /= 0.AND. &
8017 (irecmm >= nrecmm.OR.irecmm == mxrec)) THEN
8018 IF (nmatmo == 0) THEN
8019 WRITE(*,*)
8020 WRITE(*,*) 'Monitoring of sparse matrix construction'
8021 WRITE(*,*) ' records ........ off-diagonal elements ', &
8022 '....... compression memory'
8023 WRITE(*,*) ' non-zero used(double) used', &
8024 '(float) [%] [GB]'
8025 END IF
8026 nmatmo=nmatmo+1
8027 CALL ckbits(globalallindexgroups,ndimsa)
8028 gbc=1.0e-9*real((mpi*ndimsa(2)+mpd*ndimsa(3)+mps*ndimsa(4))/mpi*(bit_size(1_mpi)/8),mps) ! GB compressed
8029 gbu=1.0e-9*real(((mpi+mpd)*(ndimsa(3)+ndimsa(4)))/mpi*(bit_size(1_mpi)/8),mps) ! GB uncompressed
8030 cpr=100.0*gbc/gbu
8031 WRITE(*,1177) irecmm,ndimsa(1),ndimsa(3),ndimsa(4),cpr,gbc
80321177 FORMAT(i9,3i13,f10.2,f11.6)
8033 DO WHILE(irecmm >= nrecmm)
8034 IF (matmon > 0) THEN
8035 nrecmm=nrecmm+matmon
8036 ELSE
8037 nrecmm=nrecmm*2
8038 END IF
8039 END DO
8040 END IF
8041
8042 END IF
8043
8044 IF (nr <= 0) EXIT ! next block of events ?
8045 END DO
8046 ! release read buffer
8051
8052 WRITE(lunlog,*) 'LOOP2: event reading ended - end of data'
8053 DO k=1,3
8054 dstat(k)=dstat(k)/real(nrec,mpd)
8055 END DO
8056 ! end=of=data=end=of=data=end=of=data=end=of=data=end=of=data=end=of
8057
8058 IF (icheck > 0.AND. ncgrp > 0) THEN
8059 CALL mpdealloc(vecconsgroupindex)
8060 CALL mpdealloc(vecconsgrouplist)
8061 END IF
8062
8063 IF (icheck > 1) THEN
8065 END IF
8066 IF (icheck > 3) THEN
8067 length=ntpgrp+ncgrp
8068 CALL mpalloc(vecpairedpargroups,length,'paired global parameter groups (I)')
8069 print *
8070 print *, ' Total parameter groups pairs', ntpgrp
8071 DO i=1,ntpgrp
8072 itgbi=globaltotindexgroups(1,i)
8073 CALL ggbmap(i,npair,vecpairedpargroups)
8074 k=globalparlabelindex(4,itgbi) ! (total) group index
8075 print *, i, itgbi, globalparlabelindex(1,itgbi), npair, ':', vecpairedpargroups(:npair)
8076 END DO
8077 print *
8078 END IF
8079
8080 ! check constraints
8081 IF(matsto == 2) THEN
8082
8083 ! constraints and index pairs with Lagrange multiplier
8084 inc=max(mreqpe, msngpe+1) ! keep constraints in double precision
8085
8086 ! loop over (sorted) constraints
8087 DO jcgb=1,ncgb
8088 icgb=matconssort(3,jcgb) ! unsorted constraint index
8089 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
8090 label=listconstraints(i)%label
8091 itgbi=inone(label)
8092 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
8093 IF(ij > 0 .AND. nagb > nvgb) THEN
8095 END IF
8096 END DO
8097 END DO
8098 END IF
8099 IF(matsto == 3) THEN
8100 ! loop over (sorted) constraints
8101 DO jcgb=1,ncgb
8102 icgb=matconssort(3,jcgb) ! unsorted constraint index
8103 DO i=vecconsstart(icgb)+2,vecconsstart(icgb+1)-1
8104 label=listconstraints(i)%label
8105 itgbi=inone(label)
8106 ij=globalparlabelindex(2,itgbi) ! change to variable parameter
8107 IF(ij > 0.AND.listconstraints(i)%value /= 0.0_mpd) THEN
8108 ! non-zero coefficient
8109 CALL irbits(ij,jcgb)
8110 END IF
8111 END DO
8112 END DO
8113 END IF
8114
8115 ! check measurements
8116 IF(matsto == 2 .OR. matsto == 3) THEN
8117 ! measurements - determine index-pairs
8118
8119 i=1
8120 DO WHILE (i <= lenmeasurements)
8121 i=i+2
8122 ! loop over label/factor pairs
8123 ia=i
8124 DO
8125 i=i+1
8126 IF(i > lenmeasurements) EXIT
8127 IF(listmeasurements(i)%label < 0) EXIT
8128 END DO
8129 ib=i-1
8130
8131 DO j=ia,ib
8132 itgbij=inone(listmeasurements(j)%label) ! total parameter index
8133 ! first index
8134 ivgbij=0
8135 IF(itgbij /= 0) ivgbij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8136 DO k=ia,j
8137 itgbik=inone(listmeasurements(k)%label) ! total parameter index
8138 ! second index
8139 ivgbik=0
8140 IF(itgbik /= 0) ivgbik=globalparlabelindex(2,itgbik) ! -> index of variable global parameter
8141 IF(ivgbij > 0.AND.ivgbik > 0) THEN
8143 IF (mprint > 1) WRITE(*,*) 'add index pair ',ivgbij,ivgbik
8144 END IF
8145 END DO
8146 END DO
8147
8148 END DO
8149 ELSE
8150 ! more checks for block diagonal structure
8151 ! loop over measurements
8152 i=1
8153 DO WHILE (i <= lenmeasurements)
8154 i=i+2
8155 ! loop over label/factor pairs
8156 ia=i
8157 DO
8158 i=i+1
8159 IF(i > lenmeasurements) EXIT
8160 IF(listmeasurements(i)%label < 0) EXIT
8161 END DO
8162 ib=i-1
8163 ij1=nvgb
8164 ijn=1
8165 DO j=ia,ib
8166 itgbij=inone(listmeasurements(j)%label) ! total parameter index
8167 ! first index
8168 ij=0
8169 IF(itgbij /= 0) ij=globalparlabelindex(2,itgbij) ! -> index of variable global parameter
8170 IF (ij > 0) THEN
8171 ij1=min(ij1,ij)
8172 ijn=max(ijn,ij)
8173 END IF
8174 END DO
8175 globalindexranges(ij1)=max(globalindexranges(ij1),ijn)
8176 END DO
8177
8178 END IF
8179
8180 nummeas=0 ! number of measurement groups
8181 IF (imonit /= 0) THEN
8182 DO i=1,ntgb
8183 IF (measindex(i) > 0) THEN
8185 measres(i) = measres(i)/real(measindex(i),mpd)
8186 measindex(i) = nummeas
8187 END IF
8188 END DO
8189 length=nummeas*mthrd*measbins
8190 CALL mpalloc(meashists,length,'measurement counter')
8191 END IF
8192
8193 ! check for block diagonal structure, count blocks
8194 npblck=0
8195 l=0
8196 DO i=1,nvgb
8197 IF (i > l) npblck=npblck+1
8198 l=max(l,globalindexranges(i))
8199 globalindexranges(i)=npblck ! block number
8200 END DO
8201
8202 length=npblck+1; rows=2
8203 ! parameter blocks
8204 CALL mpalloc(matparblockoffsets,rows,length,'global parameter blocks (I)')
8206 CALL mpalloc(vecparblockconoffsets,length,'global parameter blocks (I)')
8208 ! fill matParBlocks
8209 l=0
8210 DO i=1,nvgb
8211 IF (globalindexranges(i) > l) THEN
8212 l=globalindexranges(i) ! block number
8213 matparblockoffsets(1,l)=i-1 ! block offset
8214 END IF
8215 END DO
8217 nparmx=0
8218 DO i=1,npblck
8219 rows=matparblockoffsets(1,i+1)-matparblockoffsets(1,i)
8220 nparmx=max(nparmx,int(rows,mpi))
8221 END DO
8222
8223 ! connect constraint blocks
8224 DO i=1,ncblck
8225 ia=matconsblocks(2,i) ! first parameter in constraint block
8226 IF (ia > matconsblocks(3,i)) cycle
8227 ib=globalindexranges(ia) ! parameter block number
8228 matparblockoffsets(2,ib+1)=i
8229 END DO
8230
8231 ! use diagonal block matrix storage?
8232 IF (npblck > 1) THEN
8233 IF (icheck > 0) THEN
8234 WRITE(*,*)
8235 DO i=1,npblck
8236 ia=matparblockoffsets(1,i)
8237 ib=matparblockoffsets(1,i+1)
8238 ja=matparblockoffsets(2,i)
8239 jb=matparblockoffsets(2,i+1)
8242 WRITE(*,*) ' Parameter block', i, ib-ia, jb-ja, labelf, labell
8243 ENDDO
8244 ENDIF
8245 WRITE(lunlog,*)
8246 WRITE(lunlog,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8247 WRITE(*,*)
8248 WRITE(*,*) 'Detected', npblck, '(disjoint) parameter blocks, max size ', nparmx
8249 IF ((metsol == 1.OR.metsol == 3.OR.metsol>=7).AND.nagb == nvgb) THEN
8250 WRITE(*,*) 'Using block diagonal storage mode'
8251 ELSE
8252 ! keep single block = full matrix
8253 DO i=1,2
8255 END DO
8256 npblck=1
8257 DO i=1,nvgb
8259 END DO
8260 END IF
8261 END IF
8262
8263 ! print numbers ----------------------------------------------------
8264
8265 IF (nagb >= 65536) THEN
8266 noff=int(noff8/1000,mpi)
8267 ELSE
8268 noff=int(noff8,mpi)
8269 END IF
8270 ndgn=0
8271 matwords=0
8272 IF(matsto == 2) THEN
8273 ihis=0
8274 IF (mhispe > 0) THEN
8275 ihis=15
8276 CALL hmpdef(ihis,0.0,real(mhispe,mps), 'NDBITS: #off-diagonal elements')
8277 END IF
8278 length=(napgrp+1)*nspc
8279 CALL mpalloc(sparsematrixoffsets,two,length, 'sparse matrix row offsets')
8281 ndgn=ndimsa(3)+ndimsa(4) ! actual number of off-diagonal elements
8282 matwords=ndimsa(2)+length*4 ! size of sparsity structure
8283
8284 IF (mhispe > 0) THEN
8285 IF (nhistp /= 0) CALL hmprnt(ihis)
8286 CALL hmpwrt(ihis)
8287 END IF
8288 END IF
8289 IF (matsto == 3) THEN
8290 length=nagb+1
8291 CALL mpalloc(csr3rowoffsets,length, 'sparse matrix row offsets (CSR3)')
8292 IF (mpdbsz > 1) THEN
8293 ! BSR3, check (for optimal) block size
8294 mbwrds=0
8295 DO i=1,mpdbsz
8296 npdblk=(nagb-1)/ipdbsz(i)+1
8297 length=int(npdblk,mpl)
8298 CALL mpalloc(vecblockcounts,length, 'sparse matrix row offsets (CSR3)')
8299 CALL pbsbits(globalallindexgroups,ipdbsz(i),nnzero,nblock,vecblockcounts)
8300 nbwrds=2*int(nblock,mpl)*int(ipdbsz(i)*ipdbsz(i)+1,mpl) ! number of words needed
8301 IF ((i == 1).OR.(nbwrds < mbwrds)) THEN
8302 matbsz=ipdbsz(i)
8303 mbwrds=nbwrds
8304 csr3rowoffsets(1)=1
8305 DO k=1,npdblk
8306 csr3rowoffsets(k+1)=csr3rowoffsets(k)+vecblockcounts(k)
8307 END DO
8308 END IF
8309 CALL mpdealloc(vecblockcounts)
8310 END DO
8311 ELSE
8312 ! CSR3
8314 !csr3RowOffsets(nvgb+2:)=csr3RowOffsets(nvgb+1) ! Lagrange multipliers (empty)
8315 END IF
8316 END IF
8317
8318 nagbn=maxglobalpar ! max number of global parameters in one event
8319 nalcn=maxlocalpar ! max number of local parameters in one event
8320 naeqn=maxequations ! max number of equations in one event
8323 ! matrices for event matrices
8324 ! split up cache
8325 IF (fcache(2) == 0.0) THEN ! from data (DSTAT)
8326 fcache(1)=real(dstat(1),mps)*fcache(1) ! leave some part free for fluctuations
8327 fcache(2)=real(dstat(2),mps)
8328 fcache(3)=real(dstat(3),mps)
8329 END IF
8330 fsum=fcache(1)+fcache(2)+fcache(3)
8331 DO k=1,3
8332 fcache(k)=fcache(k)/fsum
8333 END DO
8334 ncachr=nint(real(ncache,mps)*fcache(1),mpi) ! read cache
8335 ! define read buffer
8336 nc31=ncachr/(31*mthrdr) ! split read cache 1 : 10 : 10*2 for pointers, ints, floats
8337 nwrd=nc31+1
8338 length=nwrd*mthrdr
8339 CALL mpalloc(readbufferpointer,length,'read buffer, pointer')
8340 nwrd=nc31*10+2+ndimbuf
8341 length=nwrd*mthrdr
8342 CALL mpalloc(readbufferdatai,length,'read buffer, integer')
8343 CALL mpalloc(readbufferdatad,length,'read buffer, real')
8344 ! to read (old) float binary files
8345 length=(ndimbuf+2)*mthrdr
8346 CALL mpalloc(readbufferdataf,length,'read buffer, float')
8347
8348 ncachi=nint(real(ncache,mps)*fcache(2),mpi) ! index cache
8349 ncachd=ncache-ncachr-ncachi ! data cache
8350 nggd=(nagbn*nagbn+nagbn)/2+ncachd/(2*mthrd) ! number of double
8351 nggi=2+nagbn+ncachi/mthrd ! number of ints
8352 length=nagbn*mthrd
8353 CALL mpalloc(globalindexusage,length, 'global parameters (dim =max/event)')
8354 length=nvgb*mthrd
8355 CALL mpalloc(backindexusage,length,'global variable-index array')
8357 length=nagbn*nalcn
8358 CALL mpalloc(localglobalmatrix,length,'local/global matrix, content')
8359 CALL mpalloc(localglobalmap,length,'local/global matrix, map (counts)')
8360 length=2*nagbn*nalcn+nagbn+nalcn+1
8361 CALL mpalloc(localglobalstructure,length,'local/global matrix, (sparsity) structure')
8362 length=nggd*mthrd
8363 CALL mpalloc(writebufferupdates,length,'symmetric update matrices')
8364 writebufferheader(-1)=nggd ! number of words per thread
8365 writebufferheader(-2)=(nagbn*nagbn+nagbn)/2 ! min free (double) words
8366 length=nggi*mthrd
8367 CALL mpalloc(writebufferindices,length,'symmetric update matrix indices')
8368 rows=9; cols=mthrd
8369 CALL mpalloc(writebufferinfo,rows,cols,'write buffer status (I)')
8370 rows=2; cols=mthrd
8371 CALL mpalloc(writebufferdata,rows,cols,'write buffer status (F)')
8372 writebufferheader(1)=nggi ! number of words per thread
8373 writebufferheader(2)=nagbn+3 ! min free words
8374
8375 ! print all relevant dimension parameters
8376
8377 DO lu=6,8,2 ! unit 6 and 8
8378
8379 WRITE(lu,*) ' '
8380 WRITE(lu,101) 'NTGB',ntgb,'total number of parameters'
8381 WRITE(lu,102) '(all parameters, appearing in binary files)'
8382 WRITE(lu,101) 'NVGB',nvgb,'number of variable parameters'
8383 WRITE(lu,102) '(appearing in fit matrix/vectors)'
8384 WRITE(lu,101) 'NAGB',nagb,'number of all parameters'
8385 WRITE(lu,102) '(including Lagrange multiplier or reduced)'
8386 WRITE(lu,101) 'NTPGRP',ntpgrp,'total number of parameter groups'
8387 WRITE(lu,101) 'NVPGRP',nvpgrp,'number of variable parameter groups'
8388 WRITE(lu,101) 'NFGB',nfgb,'number of fit parameters'
8389 IF(metsol >= 4.AND. metsol <7) THEN ! band matrix as MINRES preconditioner
8390 WRITE(lu,101) 'MBANDW',mbandw,'band width of preconditioner matrix'
8391 WRITE(lu,102) '(if <0, no preconditioner matrix)'
8392 END IF
8393 IF (nagb >= 65536) THEN
8394 WRITE(lu,101) 'NOFF/K',noff,'max number of off-diagonal elements'
8395 ELSE
8396 WRITE(lu,101) 'NOFF',noff,'max number of off-diagonal elements'
8397 END IF
8398 IF(ndgn /= 0) THEN
8399 IF (nagb >= 65536) THEN
8400 WRITE(lu,101) 'NDGN/K',ndgn/1000,'actual number of off-diagonal elements'
8401 ELSE
8402 WRITE(lu,101) 'NDGN',ndgn,'actual number of off-diagonal elements'
8403 ENDIF
8404 ENDIF
8405 WRITE(lu,101) 'NCGB',ncgb,'number of constraints'
8406 WRITE(lu,101) 'NAGBN',nagbn,'max number of global parameters in an event'
8407 WRITE(lu,101) 'NALCN',nalcn,'max number of local parameters in an event'
8408 WRITE(lu,101) 'NAEQN',naeqn,'max number of equations in an event'
8409 IF (mprint > 1) THEN
8410 WRITE(lu,101) 'NAEQNA',naeqna,'number of equations'
8411 WRITE(lu,101) 'NAEQNG',naeqng, &
8412 'number of equations with global parameters'
8413 WRITE(lu,101) 'NAEQNF',naeqnf, &
8414 'number of equations with fixed global parameters'
8415 WRITE(lu,101) 'NRECF',nrecf, &
8416 'number of records with fixed global parameters'
8417 END IF
8418 IF (nrece > 0) THEN
8419 WRITE(lu,101) 'NRECE',nrece, &
8420 'number of records without variable parameters'
8421 END IF
8422 IF (ncache > 0) THEN
8423 WRITE(lu,101) 'NCACHE',ncache,'number of words for caching'
8424 WRITE(lu,111) (fcache(k)*100.0,k=1,3)
8425111 FORMAT(22x,'cache splitting ',3(f6.1,' %'))
8426 END IF
8427 WRITE(lu,*) ' '
8428
8429 WRITE(lu,*) ' '
8430 WRITE(lu,*) 'Solution method and matrix-storage mode:'
8431 IF(metsol == 1) THEN
8432 WRITE(lu,*) ' METSOL = 1: matrix inversion'
8433 ELSE IF(metsol == 2) THEN
8434 WRITE(lu,*) ' METSOL = 2: diagonalization'
8435 ELSE IF(metsol == 3) THEN
8436 WRITE(lu,*) ' METSOL = 3: decomposition'
8437 ELSE IF(metsol == 4) THEN
8438 WRITE(lu,*) ' METSOL = 4: MINRES (rtol', mrestl,')'
8439 ELSE IF(metsol == 5) THEN
8440 WRITE(lu,*) ' METSOL = 5: MINRES-QLP (rtol', mrestl,')'
8441 ELSE IF(metsol == 6) THEN
8442 WRITE(lu,*) ' METSOL = 6: GMRES'
8443#ifdef LAPACK64
8444 ELSE IF(metsol == 7) THEN
8445 WRITE(lu,*) ' METSOL = 7: LAPACK factorization'
8446 ELSE IF(metsol == 8) THEN
8447 WRITE(lu,*) ' METSOL = 8: LAPACK factorization'
8448#ifdef PARDISO
8449 ELSE IF(metsol == 9) THEN
8450 WRITE(lu,*) ' METSOL = 9: Intel oneMKL PARDISO'
8451#endif
8452#endif
8453 END IF
8454 WRITE(lu,*) ' with',mitera,' iterations'
8455 IF(matsto == 0) THEN
8456 WRITE(lu,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
8457 ELSE IF(matsto == 1) THEN
8458 WRITE(lu,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
8459 ELSE IF(matsto == 2) THEN
8460 WRITE(lu,*) ' MATSTO = 2: sparse matrix (custom)'
8461 ELSE IF(matsto == 3) THEN
8462 IF (matbsz < 2) THEN
8463 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
8464 ELSE
8465 WRITE(lu,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
8466 WRITE(lu,*) ' block size', matbsz
8467 END IF
8468 END IF
8469 IF(npblck > 1) THEN
8470 WRITE(lu,*) ' block diagonal with', npblck, ' blocks'
8471 END IF
8472 IF(mextnd>0) WRITE(lu,*) ' with extended storage'
8473 IF(dflim /= 0.0) THEN
8474 WRITE(lu,103) 'Convergence assumed, if expected dF <',dflim
8475 END IF
8476 IF(ncgb > 0) THEN
8477 IF(nfgb < nvgb) THEN
8478 IF (icelim > 1) THEN
8479 WRITE(lu,*) 'Constraints handled by elimination with LAPACK'
8480 ELSE
8481 WRITE(lu,*) 'Constraints handled by elimination'
8482 END IF
8483 ELSE
8484 WRITE(lu,*) 'Constraints handled by Lagrange multipliers'
8485 ENDIF
8486 END IF
8487
8488 END DO ! print loop
8489
8490 IF(nalcn == 0) THEN
8491 CALL peend(28,'Aborted, no local parameters')
8492 stop 'LOOP2: stopping due to missing local parameters'
8493 END IF
8494
8495 ! Wolfe conditions
8496
8497 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8498 IF(wolfc1 == 0.0) wolfc1=1.0e-4
8499 IF(wolfc2 == 0.0) wolfc2=0.9
8500 IF(0.0 < wolfc1.AND.wolfc1 < wolfc2.AND.wolfc2 < 1.0) GO TO 32
8501 IF(wolfc1 <= 0.0) wolfc1=1.0e-4
8502 IF(wolfc2 >= 1.0) wolfc2=0.9
8503 IF(wolfc1 > wolfc2) THEN ! exchange
8504 wolfc3=wolfc1
8506 wolfc2=wolfc3
8507 ELSE
8508 wolfc1=1.0e-4
8509 wolfc2=0.9
8510 END IF
8511 WRITE(*,105) wolfc1,wolfc2
8512 WRITE(lun,105) wolfc1,wolfc2
8513105 FORMAT(' Constants C1, C2 for Wolfe conditions:',g12.4,', ',g12.4)
8514
8515 ! prepare matrix and gradient storage ------------------------------
851632 matsiz=0 ! number of words for double, single precision storage
8517 IF (matsto == 3) THEN ! sparse matrix (CSR3, BSR3)
8518 npdblk=(nagb-1)/matbsz+1 ! number of row blocks
8519 length=csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
8520 matsiz(1)=length*int(matbsz*matbsz,mpl)
8521 matwords=(length+nagb+1)*2 ! size of sparsity structure
8522 CALL mpalloc(csr3columnlist,length,'sparse matrix column list (CSR3)')
8523 IF (matbsz > 1) THEN
8525 ELSE
8527 END IF
8528 ELSE IF (matsto == 2) THEN ! sparse matrix (custom)
8529 matsiz(1)=ndimsa(3)+nagb
8530 matsiz(2)=ndimsa(4)
8531 CALL mpalloc(sparsematrixcolumns,ndimsa(2),'sparse matrix column list')
8533 CALL anasps ! analyze sparsity structure
8534 ELSE ! full or unpacked matrix, optional block diagonal
8535 length=nagb
8536 CALL mpalloc(globalrowoffsets,length,'global row offsets (full or unpacked (block) storage)')
8537 ! loop over blocks (multiple blocks only with elimination !)
8539 DO i=1,npblck
8540 ipoff=matparblockoffsets(1,i)
8541 icboff=matparblockoffsets(2,i) ! constraint block offset
8542 icblst=matparblockoffsets(2,i+1) ! constraint block offset
8543 npar=matparblockoffsets(1,i+1)-ipoff ! size of block (number of parameters)
8544 IF (icblst > icboff) THEN
8545 ncon=matconsblocks(1,icblst+1)-matconsblocks(1,icboff+1) ! number of constraints in (parameter) block
8546 ELSE
8547 ncon=0
8548 ENDIF
8550 nall = npar; IF (icelim <= 0) nall=npar+ncon ! add Lagrange multipliers
8551 DO k=1,nall
8552 globalrowoffsets(ipoff+k)=matsiz(1)-ipoff
8553 IF (matsto == 1) THEN
8554 matsiz(1)=matsiz(1)+k ! full ('triangular')
8555 ELSE
8556 matsiz(1)=matsiz(1)+nall ! unpacked ('quadratic')
8557 END IF
8558 END DO
8559 END DO
8560 END IF
8561 matwords=matwords+matsiz(1)*2+matsiz(2) ! #words for matrix storage
8562
8563 CALL feasma ! prepare constraint matrices
8564
8565 IF (icheck <= 0) CALL vmprep(matsiz) ! prepare matrix and gradient storage
8566 WRITE(*,*) ' '
8567 IF (matwords < 250000) THEN
8568 WRITE(*,*) 'Size of global matrix: < 1 MB'
8569 ELSE
8570 WRITE(*,*) 'Size of global matrix:',int(real(matwords,mps)*4.0e-6,mpi),' MB'
8571 ENDIF
8572 ! print chi^2 cut tables
8573
8574 ndfmax=naeqn-1
8575 WRITE(lunlog,*) ' '
8576 WRITE(lunlog,*) ' Cut values of Chi^2/Ndf and Chi2,'
8577 WRITE(lunlog,*) ' corresponding to 2 and 3 standard deviations'
8578 WRITE(lunlog,*) ' Ndf Chi^2/Ndf(2) Chi^2(2) ', &
8579 ' Chi^2/Ndf(3) Chi^2(3)'
8580 ndf=0
8581 DO
8582 IF(ndf > naeqn) EXIT
8583 IF(ndf < 10) THEN
8584 ndf=ndf+1
8585 ELSE IF(ndf < 20) THEN
8586 ndf=ndf+2
8587 ELSE IF(ndf < 100) THEN
8588 ndf=ndf+5
8589 ELSE IF(ndf < 200) THEN
8590 ndf=ndf+10
8591 ELSE
8592 EXIT
8593 END IF
8594 chin2=chindl(2,ndf)
8595 chin3=chindl(3,ndf)
8596 WRITE(lunlog,106) ndf,chin2,chin2*real(ndf,mps),chin3, chin3*real(ndf,mps)
8597 END DO
8598
8599 WRITE(lunlog,*) 'LOOP2: ending'
8600 WRITE(lunlog,*) ' '
8601 ! warnings from check input mode
8602 IF (icheck > 0) THEN
8603 IF (ncgbe /= 0) THEN
8604 WRITE(*,199) ' '
8605 WRITE(*,199) ' '
8606 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8607 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8608 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8609 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8610 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8611 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8612 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8613 WRITE(*,199) ' '
8614 WRITE(*,*) ' Number of empty constraints =',abs(ncgbe), ', should be 0'
8615 WRITE(*,*) ' => please check constraint definition, mille data'
8616 WRITE(*,199) ' '
8617 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
8618 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
8619 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
8620 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
8621 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
8622 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
8623 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
8624 WRITE(*,199) ' '
8625 END IF
8626 END IF
8627 CALL mend
8628101 FORMAT(1x,a8,' =',i14,' = ',a)
8629102 FORMAT(22x,a)
8630103 FORMAT(1x,a,g12.4)
8631106 FORMAT(i6,2(3x,f9.3,f12.1,3x))
8632199 FORMAT(7x,a)
8633END SUBROUTINE loop2
8634
8639SUBROUTINE monres
8640 USE mpmod
8641 USE mpdalc
8642
8643 IMPLICIT NONE
8644 INTEGER(mpi) :: i
8645 INTEGER(mpi) :: ij
8646 INTEGER(mpi) :: imed
8647 INTEGER(mpi) :: j
8648 INTEGER(mpi) :: k
8649 INTEGER(mpi) :: nent
8650 INTEGER(mpi), DIMENSION(measBins) :: isuml ! location
8651 INTEGER(mpi), DIMENSION(measBins) :: isums ! scale
8652 REAL(mps) :: amed
8653 REAL(mps) :: amad
8654
8655 INTEGER(mpl) :: ioff
8656 LOGICAL :: lfirst
8657 SAVE
8658 DATA lfirst /.true./
8659
8660 ! combine data from threads
8661 ioff=0
8662 DO i=2,mthrd
8663 ioff=ioff+measbins*nummeas
8664 DO j=1,measbins*nummeas
8665 meashists(j)=meashists(j)+meashists(ioff+j)
8666 END DO
8667 END DO
8668
8669 IF (lfirst) THEN
8670 IF (imonmd == 0) THEN
8671 WRITE(lunmon,'(A)') '*** Normalized residuals grouped by first global label (per local fit cycle) ***'
8672 ELSE
8673 WRITE(lunmon,'(A)') '*** Pulls grouped by first global label (per local fit cycle) ***'
8674 ENDIF
8675 WRITE(lunmon,'(A)') '! LFC Label Entries Median RMS(MAD) <error>'
8676 lfirst=.false.
8677 END IF
8678
8679 !$POMP INST BEGIN(monres)
8680#ifdef SCOREP_USER_ENABLE
8681 scorep_user_region_by_name_begin("UR_monres", scorep_user_region_type_common)
8682#endif
8683 ! analyze histograms
8684 ioff=0
8685 DO i=1,ntgb
8686 IF (measindex(i) > 0) THEN
8687 isuml=0
8688 ! sum up content
8689 isuml(1)=meashists(ioff+1)
8690 DO j=2,measbins
8691 isuml(j)=isuml(j-1)+meashists(ioff+j)
8692 END DO
8693 nent=isuml(measbins)
8694 IF (nent > 0) THEN
8695 ! get median (for location)
8696 DO j=2,measbins
8697 IF (2*isuml(j) > nent) EXIT
8698 END DO
8699 imed=j
8700 amed=real(j,mps)
8701 IF (isuml(j) > isuml(j-1)) amed=amed+real(nent-2*isuml(j-1),mps)/real(2*isuml(j)-2*isuml(j-1),mps)
8702 amed=real(measbinsize,mps)*(amed-real(measbins/2,mps))
8703 ! sum up differences
8704 isums = 0
8705 DO j=imed,measbins
8706 k=j-imed+1
8707 isums(k)=isums(k)+meashists(ioff+j)
8708 END DO
8709 DO j=imed-1,1,-1
8710 k=imed-j
8711 isums(k)=isums(k)+meashists(ioff+j)
8712 END DO
8713 DO j=2, measbins
8714 isums(j)=isums(j)+isums(j-1)
8715 END DO
8716 ! get median (for scale)
8717 DO j=2,measbins
8718 IF (2*isums(j) > nent) EXIT
8719 END DO
8720 amad=real(j-1,mps)
8721 IF (isums(j) > isums(j-1)) amad=amad+real(nent-2*isums(j-1),mps)/real(2*isums(j)-2*isums(j-1),mps)
8722 amad=real(measbinsize,mps)*amad
8723 ELSE
8724 amed=0.0
8725 amad=0.0
8726 END IF
8727 ij=globalparlabelindex(1,i)
8728 WRITE(lunmon,110) nloopn, ij, nent, amed, amad*1.4826, real(measres(i),mps)
8729 !
8730 ioff=ioff+measbins
8731 END IF
8732 END DO
8733#ifdef SCOREP_USER_ENABLE
8734 scorep_user_region_by_name_end("UR_monres")
8735#endif
8736 !$POMP INST END(monres)
8737
8738110 FORMAT(i5,2i10,3g14.5)
8739END SUBROUTINE monres
8740
8741
8745
8746SUBROUTINE vmprep(msize)
8747 USE mpmod
8748 USE mpdalc
8749
8750 IMPLICIT NONE
8751 INTEGER(mpi) :: i
8752 INTEGER(mpi) :: ib
8753 INTEGER(mpi) :: ioff
8754 INTEGER(mpi) :: ipar0
8755 INTEGER(mpi) :: ncon
8756 INTEGER(mpi) :: npar
8757 INTEGER(mpi) :: nextra
8758#ifdef LAPACK64
8759 INTEGER :: nbopt, nboptx, ILAENV
8760#endif
8761 !
8762 INTEGER(mpl), INTENT(IN) :: msize(2)
8763
8764 INTEGER(mpl) :: length
8765 INTEGER(mpl) :: nwrdpc
8766 INTEGER(mpl), PARAMETER :: three = 3
8767
8768 SAVE
8769 ! ...
8770 ! Vector/matrix storage
8771 length=nagb*mthrd
8772 CALL mpalloc(globalvector,length,'rhs vector') ! double precision vector
8773 CALL mpalloc(globalcounter,length,'rhs counter') ! integer vector
8775 length=naeqn*mthrd
8776 CALL mpalloc(localcorrections,length,'residual vector of one record')
8777 CALL mpalloc(localequations,three,length,'mesurements indices (ISJAJB) of one record')
8778 length=nalcn*nalcn
8779 CALL mpalloc(aux,length,' local fit scratch array: aux')
8780 CALL mpalloc(vbnd,length,' local fit scratch array: vbnd')
8781 CALL mpalloc(vbdr,length,' local fit scratch array: vbdr')
8782 length=((nalcn+1)*nalcn)/2
8783 CALL mpalloc(clmat,length,' local fit matrix: clmat')
8784 CALL mpalloc(vbk,length,' local fit scratch array: vbk')
8785 length=nalcn
8786 CALL mpalloc(blvec,length,' local fit vector: blvec')
8787 CALL mpalloc(vzru,length,' local fit scratch array: vzru')
8788 CALL mpalloc(scdiag,length,' local fit scratch array: scdiag')
8789 CALL mpalloc(scflag,length,' local fit scratch array: scflag')
8790 CALL mpalloc(ibandh,2*length,' local fit band width hist.: ibandh')
8791
8792 CALL mpalloc(globalmatd,msize(1),'global matrix (D)' )
8793 CALL mpalloc(globalmatf,msize(2),'global matrix (F)')
8794
8795 mszpcc=0
8796 IF(metsol >= 4.AND.metsol < 7.AND. mbandw >= 0) THEN ! GMRES/MINRES algorithms
8797 ! array space is:
8798 ! variable-width band matrix or diagonal matrix for parameters
8799 ! followed by symmetric matrix for constraints
8800 ! followed by rectangular matrix for constraints
8801 nwrdpc=0
8802 ncon=nagb-nvgb ! number of Lagrange multipliers
8803 ! constraint block info
8804 length=4*ncblck; IF(ncon == 0) length=0
8805 CALL mpalloc(blockprecond,length,'preconditioner: constraint blocks')
8806 length=ncon
8807 CALL mpalloc(offprecond,length,'preconditioner: constraint offsets')
8808 !END IF
8809 ! variable-width band matrix ?
8810 IF(mbandw > 0) THEN
8811 length=nagb
8812 CALL mpalloc(indprecond,length,'pointer-array variable-band matrix')
8813 nwrdpc=nwrdpc+length
8814 DO i=1,min(mbandw,nvgb)
8815 indprecond(i)=(i*i+i)/2 ! increasing number
8816 END DO
8817 DO i=min(mbandw,nvgb)+1,nvgb
8818 indprecond(i)=indprecond(i-1)+mbandw ! fixed band width
8819 END DO
8820 DO i=nvgb+1,nagb ! reset
8821 indprecond(i)=0
8822 END DO
8823 END IF
8824 ! symmetric part
8825 length=(ncon*ncon+ncon)/2
8826 ! add 'band' part
8827 IF(mbandw > 0) THEN ! variable-width band matrix
8828 length=length+indprecond(nvgb)
8829 ELSE ! default preconditioner (diagonal)
8830 length=length+nvgb
8831 END IF
8832 ! add rectangular part (compressed, constraint blocks)
8833 IF(ncon > 0) THEN
8834 ioff=0
8835 ! extra space (for forward solution in EQUDEC)
8836 nextra=max(0,mbandw-1)
8837 DO ib=1,ncblck
8838 ! first constraint in block
8839 blockprecond(ioff+1)=matconsblocks(1,ib)
8840 ! last constraint in block
8841 blockprecond(ioff+2)=matconsblocks(1,ib+1)-1
8842 ! parameter offset
8843 ipar0=matconsblocks(2,ib)-1
8844 blockprecond(ioff+3)=ipar0
8845 ! number of parameters (-> columns)
8846 npar=matconsblocks(3,ib)-ipar0
8847 blockprecond(ioff+4)=npar+nextra
8848 DO i=blockprecond(ioff+1),blockprecond(ioff+2)
8849 offprecond(i)=length-ipar0
8850 length=length+npar+nextra
8851 mszpcc=mszpcc+npar+nextra
8852 END DO
8853 ioff=ioff+4
8854 END DO
8855 ELSE
8856 IF(mbandw == 0) length=length+1 ! for valid precons argument matPreCond((ncon*ncon+ncon)/2+nvgb+1)
8857 END IF
8858 ! allocate
8859 IF(mbandw > 0) THEN
8860 CALL mpalloc(matprecond,length,'variable-band preconditioner matrix')
8861 ELSE
8862 CALL mpalloc(matprecond,length,'default preconditioner matrix')
8863 END IF
8864 nwrdpc=nwrdpc+2*length
8865 IF (nwrdpc > 250000) THEN
8866 WRITE(*,*)
8867 WRITE(*,*) 'Size of preconditioner matrix:',int(real(nwrdpc,mps)*4.0e-6,mpi),' MB'
8868 END IF
8869
8870 END IF
8871
8872
8873 length=nagb
8874 CALL mpalloc(globalcorrections,length,'corrections') ! double prec corrections
8875
8876 length=nagb
8877 CALL mpalloc(workspaced,length,'auxiliary array (D1)') ! double aux 1
8878 CALL mpalloc(workspacelinesearch,length,'auxiliary array (D2)') ! double aux 2
8879 CALL mpalloc(workspacei, length,'auxiliary array (I)') ! int aux 1
8880
8881 IF(metsol == 1) THEN
8882 CALL mpalloc(workspacediag,length,'diagonal of global matrix)') ! double aux 1
8883 CALL mpalloc(workspacerow,length,'(pivot) row of global matrix)')
8884 ! CALL MEGARR('t D',2*NAGB,'auxiliary array') ! double aux 8
8885 END IF
8886
8887 IF(metsol == 2) THEN
8888 IF(nagb>46300) THEN
8889 CALL peend(23,'Aborted, bad matrix index (will exceed 32bit)')
8890 stop 'vmprep: bad index (matrix to large for diagonalization)'
8891 END IF
8892 CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8893 CALL mpalloc(workspacediagonalization,length,'auxiliary array (D3)') ! double aux 3
8894 CALL mpalloc(workspaceeigenvalues,length,'auxiliary array (D6)') ! double aux 6
8895 length=nagb*nagb
8896 CALL mpalloc(workspaceeigenvectors,length,'(rotation) matrix U') ! rotation matrix
8897 END IF
8898
8899 IF(metsol >= 4.AND.metsol < 7) THEN
8900 CALL mpalloc(vecxav,length,'vector X (AVPROD)') ! double aux 1
8901 CALL mpalloc(vecbav,length,'vector B (AVPROD)') ! double aux 1
8902 END IF
8903
8904#ifdef LAPACK64
8905 IF(metsol == 7) THEN
8906 IF(nagb > nvgb) CALL mpalloc(lapackipiv, length,'IPIV for DSPTRG (L)') ! pivot indices for DSPTRF
8907 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8908 END IF
8909 IF(metsol == 8) THEN
8910 IF(nagb > nvgb) THEN
8911 CALL mpalloc(lapackipiv, length,'LAPACK IPIV (L)')
8912 nbopt = ilaenv( 1_mpl, 'DSYTRF', 'U', int(nagb,mpl), int(nagb,mpl), -1_mpl, -1_mpl ) ! optimal block size
8913 print *
8914 print *, 'LAPACK optimal block size for DSYTRF:', nbopt
8915 lplwrk=length*int(nbopt,mpl)
8916 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8917 ELSE IF(nfgb < nvgb.AND.icelim > 1) THEN
8918 ! elimination of constraints with LAPACK
8919 lplwrk=1
8920 DO i=1,npblck
8921 npar=matparblockoffsets(1,i+1)-matparblockoffsets(1,i) ! number of parameters in block
8922 ncon=vecparblockconoffsets(i+1)-vecparblockconoffsets(i) ! number of constraints in block
8923 nbopt = ilaenv( 1_mpl, 'DORMQL', 'RN', int(npar,mpl), int(npar,mpl), int(ncon,mpl), int(npar,mpl) ) ! optimal buffer size
8924 IF (int(npar,mpl)*int(nbopt,mpl) > lplwrk) THEN
8925 lplwrk=int(npar,mpl)*int(nbopt,mpl)
8926 nboptx=nbopt
8927 END IF
8928 END DO
8929 print *
8930 print *, 'LAPACK optimal block size for DORMQL:', nboptx
8931 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (D)')
8932 END IF
8933 IF(ilperr == 1) CALL mpalloc(workspacediag,length,'diagonal of global matrix') ! double aux 1
8934 END IF
8935#endif
8936
8937END SUBROUTINE vmprep
8938
8942
8943SUBROUTINE minver
8944 USE mpmod
8945
8946 IMPLICIT NONE
8947 INTEGER(mpi) :: i
8948 INTEGER(mpi) :: ib
8949 INTEGER(mpi) :: icoff
8950 INTEGER(mpi) :: ipoff
8951 INTEGER(mpi) :: j
8952 INTEGER(mpi) :: lun
8953 INTEGER(mpi) :: ncon
8954 INTEGER(mpi) :: nfit
8955 INTEGER(mpi) :: npar
8956 INTEGER(mpi) :: nrank
8957 INTEGER(mpl) :: imoff
8958 INTEGER(mpl) :: ioff1
8959 REAL(mpd) :: matij
8960
8961 EXTERNAL avprds
8962
8963 SAVE
8964 ! ...
8965 lun=lunlog ! log file
8966
8967 IF(icalcm == 1) THEN
8968 ! save diagonal (for global correlation)
8969 DO i=1,nagb
8970 workspacediag(i)=matij(i,i)
8971 END DO
8972 ! use elimination for constraints ?
8973 IF(nfgb < nvgb) THEN
8974 ! monitor progress
8975 IF(monpg1 > 0) THEN
8976 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
8978 END IF
8979 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
8980 IF(monpg1 > 0) CALL monend()
8981 END IF
8982 END IF
8983
8984 ! loop over blocks (multiple blocks only with elimination !)
8985 DO ib=1,npblck
8986 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
8987 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
8988 icoff=vecparblockconoffsets(ib) ! constraint offset for block
8989 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
8990 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
8991 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
8992 ! use elimination for constraints ?
8993 IF(nfit < npar) THEN
8994 CALL qlsetb(ib)
8995 ! solve L^t*y=d by backward substitution
8997 ! transform, reduce rhs
8998 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
8999 ! correction from eliminated part
9000 DO i=1,nfit
9001 DO j=1,ncon
9002 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9004 END DO
9005 END DO
9006 END IF
9007
9008 IF(icalcm == 1) THEN
9009 ! monitor progress
9010 IF(monpg1 > 0) THEN
9011 WRITE(lunlog,*) 'Inversion of global matrix (A->A^-1)'
9013 END IF
9014 ! invert and solve
9015 CALL sqminl(globalmatd(imoff+1:), globalcorrections(ipoff+1:),nfit,nrank, &
9017 IF(monpg1 > 0) CALL monend()
9018 IF(nfit /= nrank) THEN
9019 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
9020 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9021 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
9022 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9023 IF (iforce == 0 .AND. isubit == 0) THEN
9024 isubit=1
9025 WRITE(*,*) ' --> enforcing SUBITO mode'
9026 WRITE(lun,*) ' --> enforcing SUBITO mode'
9027 END IF
9028 ELSE IF(ndefec == 0) THEN
9029 IF(npblck == 1) THEN
9030 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9031 ELSE
9032 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9033 END IF
9034 END IF
9035 ndefec=ndefec+nfit-nrank ! rank defect
9036
9037 ELSE ! multiply gradient by inverse matrix
9038 workspaced(:nfit)=globalcorrections(ipoff+1:ipoff+nfit)
9039 CALL dbsvxl(globalmatd(imoff+1:),workspaced,globalcorrections(ipoff+1:),nfit)
9040 END IF
9041
9042 !use elimination for constraints ?
9043 IF(nfit < npar) THEN
9044 ! extend, transform back solution
9045 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9046 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9047 END IF
9048 END DO
9049
9050END SUBROUTINE minver
9051
9055
9056SUBROUTINE mchdec
9057 USE mpmod
9058
9059 IMPLICIT NONE
9060 INTEGER(mpi) :: i
9061 INTEGER(mpi) :: ib
9062 INTEGER(mpi) :: icoff
9063 INTEGER(mpi) :: ipoff
9064 INTEGER(mpi) :: j
9065 INTEGER(mpi) :: lun
9066 INTEGER(mpi) :: ncon
9067 INTEGER(mpi) :: nfit
9068 INTEGER(mpi) :: npar
9069 INTEGER(mpi) :: nrank
9070 INTEGER(mpl) :: imoff
9071 INTEGER(mpl) :: ioff1
9072
9073 REAL(mpd) :: evmax
9074 REAL(mpd) :: evmin
9075
9076 EXTERNAL avprds
9077
9078 SAVE
9079 ! ...
9080 lun=lunlog ! log file
9081
9082 IF(icalcm == 1) THEN
9083 ! use elimination for constraints ?
9084 ! monitor progress
9085 IF(monpg1 > 0) THEN
9086 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9088 END IF
9089 IF(nfgb < nvgb) CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9090 IF(monpg1 > 0) CALL monend()
9091 END IF
9092
9093 ! loop over blocks (multiple blocks only with elimination !)
9094 DO ib=1,npblck
9095 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9096 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9097 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9098 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9099 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9100 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9101 ! use elimination for constraints ?
9102 IF(nfit < npar) THEN
9103 CALL qlsetb(ib)
9104 ! solve L^t*y=d by backward substitution
9106 ! transform, reduce rhs
9107 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9108 ! correction from eliminated part
9109 DO i=1,nfit
9110 DO j=1,ncon
9111 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9113 END DO
9114 END DO
9115 END IF
9116
9117 IF(icalcm == 1) THEN
9118 ! monitor progress
9119 IF(monpg1 > 0) THEN
9120 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
9122 END IF
9123 ! decompose and solve
9124 CALL chdec2(globalmatd(imoff+1:),nfit,nrank,evmax,evmin,monpg1)
9125 IF(monpg1 > 0) CALL monend()
9126 IF(nfit /= nrank) THEN
9127 WRITE(*,*) 'Warning: the rank defect of the symmetric',nfit, &
9128 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9129 WRITE(lun,*) 'Warning: the rank defect of the symmetric',nfit, &
9130 '-by-',nfit,' matrix is ',nfit-nrank,' (should be zero).'
9131 IF (iforce == 0 .AND. isubit == 0) THEN
9132 isubit=1
9133 WRITE(*,*) ' --> enforcing SUBITO mode'
9134 WRITE(lun,*) ' --> enforcing SUBITO mode'
9135 END IF
9136 ELSE IF(ndefec == 0) THEN
9137 IF(npblck == 1) THEN
9138 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9139 ELSE
9140 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9141 END IF
9142 WRITE(lun,*) ' largest diagonal element (LDLt)', evmax
9143 WRITE(lun,*) ' smallest diagonal element (LDLt)', evmin
9144 END IF
9145 ndefec=ndefec+nfit-nrank ! rank defect
9146
9147 END IF
9148 ! backward/forward substitution
9149 CALL chslv2(globalmatd(imoff+1:),globalcorrections(ipoff+1:),nfit)
9150
9151 !use elimination for constraints ?
9152 IF(nfit < npar) THEN
9153 ! extend, transform back solution
9154 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9155 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9156 END IF
9157 END DO
9158
9159END SUBROUTINE mchdec
9160
9161#ifdef LAPACK64
9162
9167
9168SUBROUTINE mdptrf
9169 USE mpmod
9170
9171 IMPLICIT NONE
9172 INTEGER(mpi) :: i
9173 INTEGER(mpi) :: ib
9174 INTEGER(mpi) :: icoff
9175 INTEGER(mpi) :: ipoff
9176 INTEGER(mpi) :: j
9177 INTEGER(mpi) :: lun
9178 INTEGER(mpi) :: ncon
9179 INTEGER(mpi) :: nfit
9180 INTEGER(mpi) :: npar
9181 INTEGER(mpl) :: imoff
9182 INTEGER(mpl) :: ioff1
9183 INTEGER(mpi) :: infolp
9184 REAL(mpd) :: matij
9185
9186 EXTERNAL avprds
9187
9188 SAVE
9189 ! ...
9190 lun=lunlog ! log file
9191
9192 IF(icalcm == 1) THEN
9193 IF(ilperr == 1) THEN
9194 ! save diagonal (for global correlation)
9195 DO i=1,nagb
9196 workspacediag(i)=matij(i,i)
9197 END DO
9198 END IF
9199 ! use elimination for constraints ?
9200 IF(nfgb < nvgb) THEN
9201 ! monitor progress
9202 IF(monpg1 > 0) THEN
9203 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9205 END IF
9206 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9207 IF(monpg1 > 0) CALL monend()
9208 END IF
9209 END IF
9210
9211 ! loop over blocks (multiple blocks only with elimination !)
9212 DO ib=1,npblck
9213 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9214 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9215 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9216 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9217 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9218 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9219 ! use elimination for constraints ?
9220 IF(nfit < npar) THEN
9221 CALL qlsetb(ib)
9222 ! solve L^t*y=d by backward substitution
9224 ! transform, reduce rhs
9225 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9226 ! correction from eliminated part
9227 DO i=1,nfit
9228 DO j=1,ncon
9229 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9231 END DO
9232 END DO
9233 END IF
9234
9235 IF(icalcm == 1) THEN
9236 ! multipliers?
9237 IF (nfit > npar) THEN
9238 ! monitor progress
9239 IF(monpg1 > 0) THEN
9240 WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
9242 END IF
9243 !$POMP INST BEGIN(dsptrf)
9244#ifdef SCOREP_USER_ENABLE
9245 scorep_user_region_by_name_begin("UR_dsptrf", scorep_user_region_type_common)
9246#endif
9247 CALL dsptrf('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),infolp)
9248#ifdef SCOREP_USER_ENABLE
9249 scorep_user_region_by_name_end("UR_dsptrf")
9250#endif
9251 !$POMP INST END(dsptrf)
9252 IF(monpg1 > 0) CALL monend()
9253 ELSE
9254 ! monitor progress
9255 IF(monpg1 > 0) THEN
9256 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9258 END IF
9259 !$POMP INST BEGIN(dpptrf)
9260#ifdef SCOREP_USER_ENABLE
9261 scorep_user_region_by_name_begin("UR_dpptrf", scorep_user_region_type_common)
9262#endif
9263 CALL dpptrf('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
9264#ifdef SCOREP_USER_ENABLE
9265 scorep_user_region_by_name_end("UR_dpptrf")
9266#endif
9267 !$POMP INST END(dpptrf)
9268 IF(monpg1 > 0) CALL monend()
9269 ENDIF
9270 ! check result
9271 IF(infolp==0) THEN
9272 IF(npblck == 1) THEN
9273 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9274 ELSE
9275 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9276 END IF
9277 ELSE
9278 ndefec=ndefec+1 ! (lower limit of) rank defect
9279 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9280 '-by-',nfit,' failed at index ', infolp
9281 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9282 '-by-',nfit,' failed at index ', infolp
9283 CALL peend(29,'Aborted, factorization of global matrix failed')
9284 stop 'mdptrf: bad matrix'
9285 END IF
9286 END IF
9287 ! backward/forward substitution
9288 ! multipliers?
9289 IF (nfit > npar) THEN
9290 CALL dsptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),lapackipiv(ipoff+1:),&
9291 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9292 IF(infolp /= 0) print *, ' DSPTRS failed: ', infolp
9293 ELSE
9294 CALL dpptrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),&
9295 globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9296 IF(infolp /= 0) print *, ' DPPTRS failed: ', infolp
9297 ENDIF
9298
9299 !use elimination for constraints ?
9300 IF(nfit < npar) THEN
9301 ! extend, transform back solution
9302 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9303 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9304 END IF
9305 END DO
9306
9307END SUBROUTINE mdptrf
9308
9314
9315SUBROUTINE mdutrf
9316 USE mpmod
9317
9318 IMPLICIT NONE
9319 INTEGER(mpi) :: i
9320 INTEGER(mpi) :: ib
9321 INTEGER(mpi) :: icoff
9322 INTEGER(mpi) :: ipoff
9323 INTEGER(mpi) :: j
9324 INTEGER(mpi) :: lun
9325 INTEGER(mpi) :: ncon
9326 INTEGER(mpi) :: nfit
9327 INTEGER(mpi) :: npar
9328 INTEGER(mpl) :: imoff
9329 INTEGER(mpl) :: ioff1
9330 INTEGER(mpl) :: iloff
9331 INTEGER(mpi) :: infolp
9332
9333 REAL(mpd) :: matij
9334
9335 EXTERNAL avprds
9336
9337 SAVE
9338 ! ...
9339 lun=lunlog ! log file
9340
9341 IF(icalcm == 1) THEN
9342 IF(ilperr == 1) THEN
9343 ! save diagonal (for global correlation)
9344 DO i=1,nagb
9345 workspacediag(i)=matij(i,i)
9346 END DO
9347 END IF
9348 ! use elimination for constraints ?
9349 IF(nfgb < nvgb) THEN
9350 ! monitor progress
9351 IF(monpg1 > 0) THEN
9352 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9354 END IF
9355 IF (icelim > 1) THEN
9356 CALL lpavat(.true.)
9357 ELSE
9358 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9359 END IF
9360 IF(monpg1 > 0) CALL monend()
9361 END IF
9362 END IF
9363
9364 ! loop over blocks (multiple blocks only with elimination !)
9365 iloff=0 ! offset of L in lapackQL
9366 DO ib=1,npblck
9367 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9368 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9369 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9370 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9371 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9372 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
9373 ! use elimination for constraints ?
9374 IF(nfit < npar) THEN
9375 IF (icelim > 1) THEN
9376 ! solve L^t*y=d by backward substitution
9377 vecconssolution(1:ncon)=vecconsresiduals(icoff+1:icoff+ncon)
9378 CALL dtrtrs('L','T','N',int(ncon,mpl),1_mpl,lapackql(iloff+npar-ncon+1:),int(npar,mpl),&
9379 vecconssolution,int(ncon,mpl),infolp)
9380 IF(infolp /= 0) print *, ' DTRTRS failed: ', infolp
9381 ! transform, reduce rhs, Q^t*b
9382 CALL dormql('L','T',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9383 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9384 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9385 ELSE
9386 CALL qlsetb(ib)
9387 ! solve L^t*y=d by backward substitution
9389 ! transform, reduce rhs
9390 CALL qlmlq(globalcorrections(ipoff+1:),1,.true.) ! Q^t*b
9391 END IF
9392 ! correction from eliminated part
9393 DO i=1,nfit
9394 DO j=1,ncon
9395 ioff1=globalrowoffsets(nfit+j+ipoff)+i+ipoff ! local (nfit+j,i)
9397 END DO
9398 END DO
9399 END IF
9400
9401 IF(icalcm == 1) THEN
9402 ! multipliers?
9403 IF (nfit > npar) THEN
9404 ! monitor progress
9405 IF(monpg1 > 0) THEN
9406 WRITE(lunlog,*) 'Factorization of global matrix (A->L*D*L^t)'
9408 END IF
9409 !$POMP INST BEGIN(dsytrf)
9410#ifdef SCOREP_USER_ENABLE
9411 scorep_user_region_by_name_begin("UR_dsytrf", scorep_user_region_type_common)
9412#endif
9413 CALL dsytrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
9414 lapackipiv(ipoff+1:),lapackwork,lplwrk,infolp)
9415#ifdef SCOREP_USER_ENABLE
9416 scorep_user_region_by_name_end("UR_dsytrf")
9417#endif
9418 !$POMP INST END(dsytrf)
9419 IF(monpg1 > 0) CALL monend()
9420 ELSE
9421 ! monitor progress
9422 IF(monpg1 > 0) THEN
9423 WRITE(lunlog,*) 'Factorization of global matrix (A->L*L^t)'
9425 END IF
9426 !$POMP INST BEGIN(dpotrf)
9427#ifdef SCOREP_USER_ENABLE
9428 scorep_user_region_by_name_begin("UR_dpotrf", scorep_user_region_type_common)
9429#endif
9430 CALL dpotrf('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
9431#ifdef SCOREP_USER_ENABLE
9432 scorep_user_region_by_name_end("UR_dpotrf")
9433#endif
9434 !$POMP INST END(dpotrf)
9435 IF(monpg1 > 0) CALL monend()
9436 ENDIF
9437 ! check result
9438 IF(infolp==0) THEN
9439 IF(npblck == 1) THEN
9440 WRITE(lun,*) 'No rank defect of the symmetric matrix'
9441 ELSE
9442 WRITE(lun,*) 'No rank defect of the symmetric block', ib, ' of size', npar
9443 END IF
9444 ELSE
9445 ndefec=ndefec+1 ! (lower limit of) rank defect
9446 WRITE(*,*) 'Warning: factorization of the symmetric',nfit, &
9447 '-by-',nfit,' failed at index ', infolp
9448 WRITE(lun,*) 'Warning: factorization of the symmetric',nfit, &
9449 '-by-',nfit,' failed at index ', infolp
9450 CALL peend(29,'Aborted, factorization of global matrix failed')
9451 stop 'mdutrf: bad matrix'
9452 END IF
9453 END IF
9454 ! backward/forward substitution
9455 ! multipliers?
9456 IF (nfit > npar) THEN
9457 CALL dsytrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(nfit,mpl),&
9458 lapackipiv(ipoff+1:),globalcorrections(ipoff+1:),int(nfit,mpl),infolp)
9459 IF(infolp /= 0) print *, ' DSYTRS failed: ', infolp
9460 ELSE
9461 CALL dpotrs('U',int(nfit,mpl),1_mpl,globalmatd(imoff+1:),int(npar,mpl),&
9462 globalcorrections(ipoff+1:),int(npar,mpl),infolp)
9463 IF(infolp /= 0) print *, ' DPOTRS failed: ', infolp
9464 ENDIF
9465
9466 !use elimination for constraints ?
9467 IF(nfit < npar) THEN
9468 IF (icelim > 1) THEN
9469 ! correction from eliminated part
9470 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9471 ! extend, transform back solution, Q*x
9472 CALL dormql('L','N',int(npar,mpl),1_mpl,int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9473 lapacktau(icoff+1:),globalcorrections(ipoff+1:),int(npar,mpl),lapackwork,lplwrk,infolp)
9474 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9475 ELSE
9476 ! extend, transform back solution
9477 globalcorrections(nfit+1+ipoff:npar+ipoff)=vecconssolution(1:ncon)
9478 CALL qlmlq(globalcorrections(ipoff+1:),1,.false.) ! Q*x
9479 END IF
9480 END IF
9481 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9482 END DO
9483
9484END SUBROUTINE mdutrf
9485
9496SUBROUTINE lpqldec(a,emin,emax)
9497 USE mpmod
9498 USE mpdalc
9499
9500 IMPLICIT NONE
9501 INTEGER(mpi) :: ib
9502 INTEGER(mpi) :: icb
9503 INTEGER(mpi) :: icboff
9504 INTEGER(mpi) :: icblst
9505 INTEGER(mpi) :: icoff
9506 INTEGER(mpi) :: icfrst
9507 INTEGER(mpi) :: iclast
9508 INTEGER(mpi) :: ipfrst
9509 INTEGER(mpi) :: iplast
9510 INTEGER(mpi) :: ipoff
9511 INTEGER(mpi) :: i
9512 INTEGER(mpi) :: j
9513 INTEGER(mpi) :: ncon
9514 INTEGER(mpi) :: npar
9515 INTEGER(mpi) :: npb
9516 INTEGER(mpl) :: imoff
9517 INTEGER(mpl) :: iloff
9518 INTEGER(mpi) :: infolp
9519 INTEGER :: nbopt, ILAENV
9520
9521 REAL(mpd), INTENT(IN) :: a(mszcon)
9522 REAL(mpd), INTENT(OUT) :: emin
9523 REAL(mpd), INTENT(OUT) :: emax
9524 SAVE
9525
9526 print *
9527 ! loop over blocks (multiple blocks only with elimination !)
9528 iloff=0 ! size of unpacked constraint matrix
9529 DO ib=1,npblck
9530 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9531 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9532 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9533 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9534 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9535 END DO
9536 ! allocate
9537 CALL mpalloc(lapackql, iloff, 'LAPACK QL (QL decomp.) ')
9538 lapackql=0.
9539 iloff=ncgb
9540 CALL mpalloc(lapacktau, iloff, 'LAPACK TAU (QL decomp.) ')
9541 ! fill
9542 iloff=0 ! offset of unpacked constraint matrix block
9543 imoff=0 ! offset of packed constraint matrix block
9544 DO ib=1,npblck
9545 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9546 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9547 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9548 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9549 IF(ncon <= 0) cycle
9550 ! block with constraints
9551 icboff=matparblockoffsets(2,ib) ! constraint block offset
9552 icblst=matparblockoffsets(2,ib+1) ! constraint block offset
9553 DO icb=icboff+1,icboff+icblst
9554 icfrst=matconsblocks(1,icb) ! first constraint in block
9555 iclast=matconsblocks(1,icb+1)-1 ! last constraint in block
9556 DO j=icfrst,iclast
9557 ipfrst=matconsranges(3,j)-ipoff ! first (rel.) parameter
9558 iplast=matconsranges(4,j)-ipoff ! last (rel.) parameters
9559 npb=iplast-ipfrst+1
9560 lapackql(iloff+ipfrst:iloff+iplast)=a(imoff+1:imoff+npb)
9561 imoff=imoff+npb
9562 iloff=iloff+npar
9563 END DO
9564 END DO
9565 END DO
9566 ! decompose
9567 iloff=0 ! offset of unpacked constraint matrix block
9568 emax=-1.
9569 emin=1.
9570 DO ib=1,npblck
9571 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9572 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9573 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9574 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9575 IF(ncon <= 0) cycle
9576 ! block with constraints
9577 nbopt = ilaenv( 1_mpl, 'DGEQLF', '', int(npar,mpl), int(ncon,mpl), int(npar,mpl), -1_mpl ) ! optimal block size
9578 print *, 'LAPACK optimal block size for DGEQLF:', nbopt
9579 lplwrk=int(ncon,mpl)*int(nbopt,mpl)
9580 CALL mpalloc(lapackwork, lplwrk,'LAPACK WORK array (d)')
9581 !$POMP INST BEGIN(dgeqlf)
9582#ifdef SCOREP_USER_ENABLE
9583 scorep_user_region_by_name_begin("UR_dgeqlf", scorep_user_region_type_common)
9584#endif
9585 CALL dgeqlf(int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),int(npar,mpl),&
9586 lapacktau(icoff+1:),lapackwork,lplwrk,infolp)
9587 IF(infolp /= 0) print *, ' DGEQLF failed: ', infolp
9588#ifdef SCOREP_USER_ENABLE
9589 scorep_user_region_by_name_end("UR_dgeqlf")
9590#endif
9591 !$POMP INST END(dgeqlf)
9592 CALL mpdealloc(lapackwork)
9593 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9594 ! get min/max diaginal element of L
9595 imoff=iloff
9596 IF(emax < emin) THEN
9597 emax=lapackql(imoff)
9598 emin=emax
9599 END IF
9600 DO i=1,ncon
9601 IF (abs(emax) < abs(lapackql(imoff))) emax=lapackql(imoff)
9602 IF (abs(emin) > abs(lapackql(imoff))) emin=lapackql(imoff)
9603 imoff=imoff-npar-1
9604 END DO
9605 END DO
9606 print *
9607END SUBROUTINE lpqldec
9608
9618SUBROUTINE lpavat(t)
9619 USE mpmod
9620
9621 IMPLICIT NONE
9622 INTEGER(mpi) :: i
9623 INTEGER(mpi) :: ib
9624 INTEGER(mpi) :: icoff
9625 INTEGER(mpi) :: ipoff
9626 INTEGER(mpi) :: j
9627 INTEGER(mpi) :: ncon
9628 INTEGER(mpi) :: npar
9629 INTEGER(mpl) :: imoff
9630 INTEGER(mpl) :: iloff
9631 INTEGER(mpi) :: infolp
9632 CHARACTER (LEN=1) :: transr, transl
9633
9634 LOGICAL, INTENT(IN) :: t
9635 SAVE
9636
9637 IF (t) THEN ! Q^t*A*Q
9638 transr='N'
9639 transl='T'
9640 ELSE ! Q*A*Q^t
9641 transr='T'
9642 transl='N'
9643 ENDIF
9644
9645 ! loop over blocks (multiple blocks only with elimination !)
9646 iloff=0 ! offset of L in lapackQL
9647 DO ib=1,npblck
9648 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
9649 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
9650 icoff=vecparblockconoffsets(ib) ! constraint offset for block
9651 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
9652 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
9653 IF(ncon <= 0 ) cycle
9654
9655 !$POMP INST BEGIN(dormql)
9656#ifdef SCOREP_USER_ENABLE
9657 scorep_user_region_by_name_begin("UR_dormql", scorep_user_region_type_common)
9658#endif
9659 ! expand matrix (copy lower to upper triangle)
9660 ! parallelize row loop
9661 ! slot of 32 'I' for next idle thread
9662 !$OMP PARALLEL DO &
9663 !$OMP PRIVATE(J) &
9664 !$OMP SCHEDULE(DYNAMIC,32)
9665 DO i=ipoff+1,ipoff+npar
9666 DO j=ipoff+1,i-1
9668 ENDDO
9669 ENDDO
9670 ! A*Q
9671 CALL dormql('R',transr,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9672 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9673 lapackwork,lplwrk,infolp)
9674 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9675 ! Q^t*(A*Q)
9676 CALL dormql('L',transl,int(npar,mpl),int(npar,mpl),int(ncon,mpl),lapackql(iloff+1:),&
9677 int(npar,mpl),lapacktau(icoff+1:),globalmatd(imoff+1:),int(npar,mpl),&
9678 lapackwork,lplwrk,infolp)
9679 IF(infolp /= 0) print *, ' DORMQL failed: ', infolp
9680#ifdef SCOREP_USER_ENABLE
9681 scorep_user_region_by_name_end("UR_dormql")
9682#endif
9683 !$POMP INST END(dormql)
9684
9685 iloff=iloff+int(npar,mpl)*int(ncon,mpl)
9686 END DO
9687
9688END SUBROUTINE lpavat
9689
9690#ifdef PARDISO
9691include 'mkl_pardiso.f90'
9692!===============================================================================
9693! Copyright 2004-2022 Intel Corporation.
9694!
9695! This software and the related documents are Intel copyrighted materials, and
9696! your use of them is governed by the express license under which they were
9697! provided to you (License). Unless the License provides otherwise, you may not
9698! use, modify, copy, publish, distribute, disclose or transmit this software or
9699! the related documents without Intel's prior written permission.
9700!
9701! This software and the related documents are provided as is, with no express
9702! or implied warranties, other than those that are expressly stated in the
9703! License.
9704!===============================================================================
9705!
9706! Content : Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO Fortran-90
9707! use case
9708!
9709!*******************************************************************************
9710
9715SUBROUTINE mspardiso
9716 USE mkl_pardiso
9717 USE mpmod
9718 USE mpdalc
9719 IMPLICIT NONE
9720
9721 !.. Internal solver memory pointer
9722 TYPE(mkl_pardiso_handle) :: pt(64) ! Handle to internal data structure
9723 !.. All other variables
9724 INTEGER(mpl), PARAMETER :: maxfct =1 ! Max. number of factors with identical sparsity structure kept in memory
9725 INTEGER(mpl), PARAMETER :: mnum = 1 ! Actual factor to use
9726 INTEGER(mpl), PARAMETER :: nrhs = 1 ! Number of right hand sides
9727
9728 INTEGER(mpl) :: mtype ! Matrix type (symmetric, pos. def.: 2, indef.: -2)
9729 INTEGER(mpl) :: phase ! Solver phase(s) to be executed
9730 INTEGER(mpl) :: error ! Error code
9731 INTEGER(mpl) :: msglvl ! Message level
9732
9733 INTEGER(mpi) :: i
9734 INTEGER(mpl) :: ij
9735 INTEGER(mpl) :: idum(1)
9736 INTEGER(mpi) :: lun
9737 INTEGER(mpl) :: length
9738 INTEGER(mpi) :: nfill
9739 INTEGER(mpi) :: npdblk
9740 REAL(mpd) :: adum(1)
9741 REAL(mpd) :: ddum(1)
9742
9743 INTEGER(mpl) :: iparm(64)
9744 REAL(mpd), ALLOCATABLE :: b( : ) ! Right hand side (of equations system)
9745 REAL(mpd), ALLOCATABLE :: x( : ) ! Solution (of equations system)
9746 SAVE
9747
9748 lun=lunlog ! log file
9749
9750 error = 0 ! initialize error flag
9751 msglvl = ipddbg ! print statistical information
9752 npdblk=(nfgb-1)/matbsz+1 ! number of row blocks
9753
9754 IF(icalcm == 1) THEN
9755 mtype = 2 ! positive definite symmetric matrix
9756 IF (nfgb > nvgb) mtype = -2 ! indefinte symmetric matrix (Lagrange multipliers)
9757
9758 !$POMP INST BEGIN(mspd00)
9759#ifdef SCOREP_USER_ENABLE
9760 scorep_user_region_by_name_begin("UR_mspd00", scorep_user_region_type_common)
9761#endif
9762 WRITE(*,*)
9763 WRITE(*,*) 'MSPARDISO: number of non-zero elements = ', csr3rowoffsets(npdblk+1)-csr3rowoffsets(1)
9764 ! fill up last block?
9765 nfill = npdblk*matbsz-nfgb
9766 IF (nfill > 0) THEN
9767 WRITE(*,*) 'MSPARDISO: number of rows to fill up = ', nfill
9768 ! end of last block
9769 ij = (csr3rowoffsets(npdblk+1)-csr3rowoffsets(1))*int(matbsz,mpl)*int(matbsz,mpl)
9770 DO i=1,nfill
9771 globalmatd(ij) = 1.0_mpd
9772 ij = ij-matbsz-1 ! back one row and one column in last block
9773 END DO
9774 END IF
9775
9776 ! close previous PARADISO run
9777 IF (ipdmem > 0) THEN
9778 !.. Termination and release of memory
9779 phase = -1 ! release internal memory
9780 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), adum, idum, idum, &
9781 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9782 IF (error /= 0) THEN
9783 WRITE(lun,*) 'The following ERROR was detected: ', error
9784 WRITE(*,'(A,2I10)') ' PARDISO release failed (phase, error): ', phase, error
9785 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9786 CALL peend(40,'Aborted, other error: PARDISO release')
9787 stop 'MSPARDISO: stopping due to error in PARDISO release'
9788 END IF
9789 ipdmem=0
9790 END IF
9791
9792 !..
9793 !.. Set up PARDISO control parameter
9794 !..
9795 iparm=0 ! using defaults
9796 iparm(2) = 2 ! fill-in reordering from METIS
9797 iparm(10) = 8 ! perturb the pivot elements with 1E-8
9798 iparm(18) = -1 ! Output: number of nonzeros in the factor LU
9799 iparm(19) = -1 ! Output: Mflops for LU factorization
9800 iparm(21) = 1 ! pivoting for symmetric indefinite matrices
9801 DO i=1, lenpardiso
9802 iparm(listpardiso(i)%label)=listpardiso(i)%ivalue
9803 END DO
9804 IF (iparm(1) == 0) WRITE(lun,*) 'PARDISO using defaults '
9805 IF (iparm(43) /= 0) THEN
9806 WRITE(lun,*) 'PARDISO: computation of the diagonal of inverse matrix not implemented !'
9807 iparm(43) = 0 ! no computation of the diagonal of inverse matrix
9808 END IF
9809
9810 ! necessary for the FIRST call of the PARDISO solver.
9811 DO i = 1, 64
9812 pt(i)%DUMMY = 0
9813 END DO
9814#ifdef SCOREP_USER_ENABLE
9815 scorep_user_region_by_name_end("UR_mspd00")
9816#endif
9817 !$POMP INST END(mspd00)
9818 END IF
9819
9820 IF(icalcm == 1) THEN
9821 ! monitor progress
9822 IF(monpg1 > 0) THEN
9823 WRITE(lunlog,*) 'Decomposition of global matrix (A->L*D*L^t)'
9825 END IF
9826 ! decompose and solve
9827 !.. Reordering and Symbolic Factorization, This step also allocates
9828 ! all memory that is necessary for the factorization
9829 !$POMP INST BEGIN(mspd11)
9830#ifdef SCOREP_USER_ENABLE
9831 scorep_user_region_by_name_begin("UR_mspd11", scorep_user_region_type_common)
9832#endif
9833 phase = 11 ! only reordering and symbolic factorization
9834 IF (matbsz > 1) THEN
9835 iparm(1) = 1 ! non default setting
9836 iparm(37) = matbsz ! using BSR3 instead of CSR3
9837 END IF
9838 IF (ipddbg > 0) THEN
9839 DO i=1,64
9840 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9841 END DO
9842 END IF
9843 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9844 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9845#ifdef SCOREP_USER_ENABLE
9846 scorep_user_region_by_name_end("UR_mspd11")
9847#endif
9848 !$POMP INST END(mspd11)
9849 WRITE(lun,*) 'PARDISO reordering completed ... '
9850 WRITE(lun,*) 'PARDISO peak memory required (KB)', iparm(15)
9851 IF (ipddbg > 0) THEN
9852 DO i=1,64
9853 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9854 END DO
9855 END IF
9856 IF (error /= 0) THEN
9857 WRITE(lun,*) 'The following ERROR was detected: ', error
9858 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9859 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9860 CALL peend(40,'Aborted, other error: PARDISO reordering')
9861 stop 'MSPARDISO: stopping due to error in PARDISO reordering'
9862 END IF
9863 IF (iparm(60) == 0) THEN
9864 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(17) ! in core
9865 ELSE
9866 ipdmem=ipdmem+max(iparm(15),iparm(16))+iparm(63) ! out of core
9867 END IF
9868 WRITE(lun,*) 'Size (KB) of allocated memory = ',ipdmem
9869 WRITE(lun,*) 'Number of nonzeros in factors = ',iparm(18)
9870 WRITE(lun,*) 'Number of factorization MFLOPS = ',iparm(19)
9871
9872 !.. Factorization.
9873 !$POMP INST BEGIN(mspd22)
9874#ifdef SCOREP_USER_ENABLE
9875 scorep_user_region_by_name_begin("UR_mspd22", scorep_user_region_type_common)
9876#endif
9877 phase = 22 ! only factorization
9878 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9879 idum, nrhs, iparm, msglvl, ddum, ddum, error)
9880#ifdef SCOREP_USER_ENABLE
9881 scorep_user_region_by_name_end("UR_mspd22")
9882#endif
9883 !$POMP INST END(mspd22)
9884 WRITE(lun,*) 'PARDISO factorization completed ... '
9885 IF (ipddbg > 0) THEN
9886 DO i=1,64
9887 WRITE(lun,*) ' iparm(',i,') =', iparm(i)
9888 END DO
9889 END IF
9890 IF (error /= 0) THEN
9891 WRITE(lun,*) 'The following ERROR was detected: ', error
9892 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9893 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9894 CALL peend(40,'Aborted, other error: PARDISO factorization')
9895 stop 'MSPARDISO: stopping due to error in PARDISO factorization'
9896 ENDIF
9897 IF (mtype < 0) THEN
9898 IF (iparm(14) > 0) &
9899 WRITE(lun,*) 'Number of perturbed pivots = ',iparm(14)
9900 WRITE(lun,*) 'Number of positive eigenvalues = ',iparm(22)-nfill
9901 WRITE(lun,*) 'Number of negative eigenvalues = ',iparm(23)
9902 ELSE IF (iparm(30) > 0) THEN
9903 WRITE(lun,*) 'Equation with bad pivot (<=0.) = ',iparm(30)
9904 END IF
9905
9906 IF (monpg1 > 0) CALL monend()
9907 END IF
9908
9909 ! backward/forward substitution
9910 !.. Back substitution and iterative refinement
9911 length=nfgb+nfill
9912 CALL mpalloc(b,length,' PARDISO r.h.s')
9913 CALL mpalloc(x,length,' PARDISO solution')
9915 !$POMP INST BEGIN(mspd33)
9916#ifdef SCOREP_USER_ENABLE
9917 scorep_user_region_by_name_begin("UR_mspd33", scorep_user_region_type_common)
9918#endif
9919 iparm(6) = 0 ! don't update r.h.s. with solution
9920 phase = 33 ! only solving
9921 CALL pardiso_64(pt, maxfct, mnum, mtype, phase, int(npdblk,mpl), globalmatd, csr3rowoffsets, csr3columnlist, &
9922 idum, nrhs, iparm, msglvl, b, x, error)
9923#ifdef SCOREP_USER_ENABLE
9924 scorep_user_region_by_name_end("UR_mspd33")
9925#endif
9926 !$POMP INST END(mspd33)
9928 CALL mpdealloc(x)
9929 CALL mpdealloc(b)
9930 WRITE(lun,*) 'PARDISO solve completed ... '
9931 IF (error /= 0) THEN
9932 WRITE(lun,*) 'The following ERROR was detected: ', error
9933 WRITE(*,'(A,2I10)') ' PARDISO decomposition failed (phase, error): ', phase, error
9934 IF (ipddbg == 0) WRITE(*,*) ' rerun with "debugPARDISO" for more info'
9935 CALL peend(40,'Aborted, other error: PARDISO solve')
9936 stop 'MSPARDISO: stopping due to error in PARDISO solve'
9937 ENDIF
9938
9939END SUBROUTINE mspardiso
9940#endif
9941#endif
9942
9944SUBROUTINE mdiags
9945 USE mpmod
9946
9947 IMPLICIT NONE
9948 REAL(mps) :: evalue
9949 INTEGER(mpi) :: i
9950 INTEGER(mpi) :: iast
9951 INTEGER(mpi) :: idia
9952 INTEGER(mpi) :: imin
9953 INTEGER(mpl) :: ioff1
9954 INTEGER(mpi) :: j
9955 INTEGER(mpi) :: last
9956 INTEGER(mpi) :: lun
9957 INTEGER(mpi) :: nmax
9958 INTEGER(mpi) :: nmin
9959 INTEGER(mpi) :: ntop
9960 REAL(mpd) :: matij
9961 !
9962 EXTERNAL avprds
9963
9964 SAVE
9965 ! ...
9966
9967 lun=lunlog ! log file
9968
9969 ! save diagonal (for global correlation)
9970 IF(icalcm == 1) THEN
9971 DO i=1,nagb
9972 workspacediag(i)=matij(i,i)
9973 END DO
9974 ENDIF
9975
9976 !use elimination for constraints ?
9977 IF(nfgb < nvgb) THEN
9978 IF(icalcm == 1) THEN
9979 ! monitor progress
9980 IF(monpg1 > 0) THEN
9981 WRITE(lunlog,*) 'Shrinkage of global matrix (A->Q^t*A*Q)'
9983 END IF
9984 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.true.) ! Q^t*A*Q
9985 IF(monpg1 > 0) CALL monend()
9986 ENDIF
9987 ! solve L^t*y=d by backward substitution
9989 ! transform, reduce rhs
9990 CALL qlmlq(globalcorrections,1,.true.) ! Q^t*b
9991 ! correction from eliminated part
9992 DO i=1,nfgb
9993 DO j=1,ncgb
9994 ioff1=globalrowoffsets(nfgb+j)+i ! global (nfit+j,i)
9996 END DO
9997 END DO
9998 END IF
9999
10000 IF(icalcm == 1) THEN
10001 ! eigenvalues eigenvectors symm_input
10002 workspaceeigenvalues=0.0_mpd
10005
10006 ! histogram of positive eigenvalues
10007
10008 nmax=int(1.0+log10(real(workspaceeigenvalues(1),mps)),mpi) ! > log of largest eigenvalue
10009 imin=1
10010 DO i=nfgb,1,-1
10011 IF(workspaceeigenvalues(i) > 0.0_mpd) THEN
10012 imin=i ! index of smallest pos. eigenvalue
10013 EXIT
10014 END IF
10015 END DO
10016 nmin=int(log10(real(workspaceeigenvalues(imin),mps)),mpi) ! log of smallest pos. eigenvalue
10017 ntop=nmin+6
10018 DO WHILE(ntop < nmax)
10019 ntop=ntop+3
10020 END DO
10021
10022 CALL hmpdef(7,real(nmin,mps),real(ntop,mps), 'log10 of positive eigenvalues')
10023 DO idia=1,nfgb
10024 IF(workspaceeigenvalues(idia) > 0.0_mpd) THEN ! positive
10025 evalue=log10(real(workspaceeigenvalues(idia),mps))
10026 CALL hmpent(7,evalue)
10027 END IF
10028 END DO
10029 IF(nhistp /= 0) CALL hmprnt(7)
10030 CALL hmpwrt(7)
10031
10032 iast=max(1,imin-60)
10033 CALL gmpdef(3,2,'low-value end of eigenvalues')
10034 DO i=iast,nfgb
10035 evalue=real(workspaceeigenvalues(i),mps)
10036 CALL gmpxy(3,real(i,mps),evalue)
10037 END DO
10038 IF(nhistp /= 0) CALL gmprnt(3)
10039 CALL gmpwrt(3)
10040
10041 DO i=1,nfgb
10042 workspacediagonalization(i)=0.0_mpd
10043 IF(workspaceeigenvalues(i) /= 0.0_mpd) THEN
10044 workspacediagonalization(i)=max(0.0_mpd,log10(abs(workspaceeigenvalues(i)))+3.0_mpd)
10046 END IF
10047 END DO
10048 last=min(nfgb,nvgb)
10049 WRITE(lun,*) ' '
10050 WRITE(lun,*) 'The first (largest) eigenvalues ...'
10051 WRITE(lun,102) (workspaceeigenvalues(i),i=1,min(20,nagb))
10052 WRITE(lun,*) ' '
10053 WRITE(lun,*) 'The last eigenvalues ... up to',last
10054 WRITE(lun,102) (workspaceeigenvalues(i),i=max(1,last-19),last)
10055 WRITE(lun,*) ' '
10056 IF(nagb > nvgb) THEN
10057 WRITE(lun,*) 'The eigenvalues from',nvgb+1,' to',nagb
10058 WRITE(lun,102) (workspaceeigenvalues(i),i=nvgb+1,nagb)
10059 WRITE(lun,*) ' '
10060 ENDIF
10061 WRITE(lun,*) 'Log10 + 3 of ',nfgb,' eigenvalues in decreasing', ' order'
10062 WRITE(lun,*) '(for Eigenvalue < 0.001 the value 0.0 is shown)'
10063 WRITE(lun,101) (workspacediagonalization(i),i=1,nfgb)
10064 IF(workspacediagonalization(nfgb) < 0) WRITE(lun,*) 'Negative values are ', &
10065 'printed for negative eigenvalues'
10067 WRITE(lun,*) ' '
10068 WRITE(lun,*) last,' significances: insignificant if ', &
10069 'compatible with N(0,1)'
10070 WRITE(lun,101) (workspacediagonalization(i),i=1,last)
10071
10072
10073101 FORMAT(10f7.1)
10074102 FORMAT(5e14.6)
10075
10076 END IF
10077
10078 ! solution ---------------------------------------------------------
10080 ! eigenvalues eigenvectors
10082
10083 !use elimination for constraints ?
10084 IF(nfgb < nvgb) THEN
10085 ! extend, transform back solution
10087 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10088 END IF
10089
10090END SUBROUTINE mdiags
10091
10093SUBROUTINE zdiags
10094 USE mpmod
10095
10096 IMPLICIT NONE
10097 INTEGER(mpi) :: i
10098 INTEGER(mpl) :: ioff1
10099 INTEGER(mpl) :: ioff2
10100 INTEGER(mpi) :: j
10101
10102 ! eigenvalue eigenvectors cov.matrix
10104
10105 !use elimination for constraints ?
10106 IF(nfgb < nvgb) THEN
10107 ! extend, transform eigenvectors
10108 ioff1=nfgb*nfgb
10109 ioff2=nfgb*nvgb
10110 workspaceeigenvectors(ioff2+1:)=0.0_mpd
10111 DO i=nfgb,1,-1
10112 ioff1=ioff1-nfgb
10113 ioff2=ioff2-nvgb
10114 DO j=nfgb,1,-1
10116 END DO
10117 workspaceeigenvectors(ioff2+nfgb+1:ioff2+nvgb)=0.0_mpd
10118 END DO
10119 CALL qlmlq(workspaceeigenvectors,nvgb,.false.) ! Q*U
10120 END IF
10121
10122END SUBROUTINE zdiags
10123
10129
10130SUBROUTINE mminrs
10131 USE mpmod
10132 USE minresmodule, ONLY: minres
10133
10134 IMPLICIT NONE
10135 INTEGER(mpi) :: istop
10136 INTEGER(mpi) :: itn
10137 INTEGER(mpi) :: itnlim
10138 INTEGER(mpi) :: lun
10139 INTEGER(mpi) :: nout
10140 INTEGER(mpi) :: nrkd
10141 INTEGER(mpi) :: nrkd2
10142
10143 REAL(mpd) :: shift
10144 REAL(mpd) :: rtol
10145 REAL(mpd) :: anorm
10146 REAL(mpd) :: acond
10147 REAL(mpd) :: arnorm
10148 REAL(mpd) :: rnorm
10149 REAL(mpd) :: ynorm
10150 LOGICAL :: checka
10151 EXTERNAL avprds, avprod, mvsolv, mcsolv
10152 SAVE
10153 ! ...
10154 lun=lunlog ! log file
10155
10156 nout=lun
10157 itnlim=2000 ! iteration limit
10158 shift =0.0_mpd ! not used
10159 rtol = mrestl ! from steering
10160 checka=.false.
10161
10163 !use elimination for constraints ?
10164 IF(nfgb < nvgb) THEN
10165 ! solve L^t*y=d by backward substitution
10167 ! input to AVPRD0
10168 vecxav(1:nfgb)=0.0_mpd
10170 CALL qlmlq(vecxav,1,.false.) ! Q*x
10171 ! calclulate vecBav=globalMat*vecXav
10172 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
10173 ! correction from eliminated part
10175 ! transform, reduce rhs
10176 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
10177 END IF
10178
10179 IF(mbandw == 0) THEN ! default preconditioner
10180 IF(icalcm == 1) THEN
10181 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
10182 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10183 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
10185 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
10186 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
10187 IF(monpg1 > 0) CALL monend()
10188 END IF
10189 CALL minres(nfgb, avprod, mcsolv, workspaced, shift, checka ,.true. , &
10190 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10191 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
10192 IF(icalcm == 1) THEN
10193 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
10194 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10195 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
10197 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
10198 IF(monpg1 > 0) CALL monend()
10199 END IF
10200 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.true. , &
10201 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10202 ELSE
10203 CALL minres(nfgb, avprod, mvsolv, workspaced, shift, checka ,.false. , &
10204 globalcorrections, itnlim, nout, rtol, istop, itn, anorm, acond, rnorm, arnorm, ynorm)
10205 END IF
10206
10207 !use elimination for constraints ?
10208 IF(nfgb < nvgb) THEN
10209 ! extend, transform back solution
10211 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10212 END IF
10213
10214 iitera=itn
10215 istopa=istop
10216 mnrsit=mnrsit+itn
10217
10218 IF (istopa == 0) print *, 'MINRES: istop=0, exact solution x=0.'
10219
10220END SUBROUTINE mminrs
10221
10227
10228SUBROUTINE mminrsqlp
10229 USE mpmod
10230 USE minresqlpmodule, ONLY: minresqlp
10231
10232 IMPLICIT NONE
10233 INTEGER(mpi) :: istop
10234 INTEGER(mpi) :: itn
10235 INTEGER(mpi) :: itnlim
10236 INTEGER(mpi) :: lun
10237 INTEGER(mpi) :: nout
10238 INTEGER(mpi) :: nrkd
10239 INTEGER(mpi) :: nrkd2
10240
10241 REAL(mpd) :: rtol
10242 REAL(mpd) :: mxxnrm
10243 REAL(mpd) :: trcond
10244
10245 EXTERNAL avprds, avprod, mvsolv, mcsolv
10246 SAVE
10247 ! ...
10248 lun=lunlog ! log file
10249
10250 nout=lun
10251 itnlim=2000 ! iteration limit
10252 rtol = mrestl ! from steering
10253 mxxnrm = real(nagb,mpd)/sqrt(epsilon(mxxnrm))
10254 IF(mrmode == 1) THEN
10255 trcond = 1.0_mpd/epsilon(trcond) ! only QR
10256 ELSE IF(mrmode == 2) THEN
10257 trcond = 1.0_mpd ! only QLP
10258 ELSE
10259 trcond = mrtcnd ! QR followed by QLP
10260 END IF
10261
10263 !use elimination for constraints ?
10264 IF(nfgb < nvgb) THEN
10265 ! solve L^t*y=d by backward substitution
10267 ! input to AVPRD0
10268 vecxav(1:nfgb)=0.0_mpd
10270 CALL qlmlq(vecxav,1,.false.) ! Q*x
10271 ! calclulate vecBav=globalMat*vecXav
10272 CALL avprd0(nagb,0_mpl,vecxav,vecbav)
10273 ! correction from eliminated part
10275 ! transform, reduce rhs
10276 CALL qlmlq(workspaced,1,.true.) ! Q^t*b
10277 END IF
10278
10279 IF(mbandw == 0) THEN ! default preconditioner
10280 IF(icalcm == 1) THEN
10281 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,1,.true.) ! transform preconditioner matrix
10282 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10283 WRITE(lun,*) 'MMINRS: PRECONS started', nprecond(2), nprecond(1)
10285 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),nrkd)
10286 WRITE(lun,*) 'MMINRS: PRECONS ended ', nrkd
10287 IF(monpg1 > 0) CALL monend()
10288 END IF
10289 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mcsolv, nout=nout, &
10290 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10291 x=globalcorrections, istop=istop, itn=itn)
10292 ELSE IF(mbandw > 0) THEN ! band matrix preconditioner
10293 IF(icalcm == 1) THEN
10294 IF(nfgb < nvgb) CALL qlpssq(avprds,matprecond,mbandw,.true.) ! transform preconditioner matrix
10295 IF(monpg1 > 0) CALL monini(lunlog,monpg1,monpg2)
10296 WRITE(lun,*) 'MMINRS: EQUDECS started', nprecond(2), nprecond(1)
10298 WRITE(lun,*) 'MMINRS: EQUDECS ended ', nrkd, nrkd2
10299 IF(monpg1 > 0) CALL monend()
10300 END IF
10301
10302 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, msolve=mvsolv, nout=nout, &
10303 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10304 x=globalcorrections, istop=istop, itn=itn)
10305 ELSE
10306 CALL minresqlp( n=nfgb, aprod=avprod, b=workspaced, nout=nout, &
10307 itnlim=itnlim, rtol=rtol, maxxnorm=mxxnrm, trancond=trcond, &
10308 x=globalcorrections, istop=istop, itn=itn)
10309 END IF
10310
10311 !use elimination for constraints ?
10312 IF(nfgb < nvgb) THEN
10313 ! extend, transform back solution
10315 CALL qlmlq(globalcorrections,1,.false.) ! Q*x
10316 END IF
10317
10318 iitera=itn
10319 istopa=istop
10320 mnrsit=mnrsit+itn
10321
10322 IF (istopa == 3) print *, 'MINRES: istop=0, exact solution x=0.'
10323
10324END SUBROUTINE mminrsqlp
10325
10333
10334SUBROUTINE mcsolv(n,x,y) ! solve M*y = x
10335 USE mpmod
10336
10337 IMPLICIT NONE
10338 INTEGER(mpi),INTENT(IN) :: n
10339 REAL(mpd), INTENT(IN) :: x(n)
10340 REAL(mpd), INTENT(OUT) :: y(n)
10341 SAVE
10342 ! ...
10344 matprecond(1+nvgb+(nprecond(1)*(nprecond(1)+1))/2),blockprecond,matprecond(1+nvgb),y,x)
10345END SUBROUTINE mcsolv
10346
10354
10355SUBROUTINE mvsolv(n,x,y) ! solve M*y = x
10356 USE mpmod
10357
10358 IMPLICIT NONE
10359
10360 INTEGER(mpi), INTENT(IN) :: n
10361 REAL(mpd), INTENT(IN) :: x(n)
10362 REAL(mpd), INTENT(OUT) :: y(n)
10363
10364 SAVE
10365 ! ...
10366 y=x ! copy to output vector
10367
10369END SUBROUTINE mvsolv
10370
10371
10372
10373!***********************************************************************
10374
10387
10388SUBROUTINE xloopn !
10389 USE mpmod
10390
10391 IMPLICIT NONE
10392 REAL(mps) :: catio
10393 REAL(mps) :: concu2
10394 REAL(mps) :: concut
10395 REAL, DIMENSION(2) :: ta
10396 REAL etime
10397 INTEGER(mpi) :: i
10398 INTEGER(mpi) :: iact
10399 INTEGER(mpi) :: iagain
10400 INTEGER(mpi) :: idx
10401 INTEGER(mpi) :: info
10402 INTEGER(mpi) :: ib
10403 INTEGER(mpi) :: ipoff
10404 INTEGER(mpi) :: icoff
10405 INTEGER(mpl) :: ioff
10406 INTEGER(mpi) :: itgbi
10407 INTEGER(mpi) :: ivgbi
10408 INTEGER(mpi) :: jcalcm
10409 INTEGER(mpi) :: k
10410 INTEGER(mpi) :: labelg
10411 INTEGER(mpi) :: litera
10412 INTEGER(mpl) :: lrej
10413 INTEGER(mpi) :: lun
10414 INTEGER(mpi) :: lunp
10415 INTEGER(mpi) :: minf
10416 INTEGER(mpi) :: mrati
10417 INTEGER(mpi) :: nan
10418 INTEGER(mpi) :: ncon
10419 INTEGER(mpi) :: nfaci
10420 INTEGER(mpi) :: nloopsol
10421 INTEGER(mpi) :: npar
10422 INTEGER(mpi) :: nrati
10423 INTEGER(mpl) :: nrej
10424 INTEGER(mpi) :: nsol
10425 INTEGER(mpi) :: inone
10426#ifdef LAPACK64
10427 INTEGER(mpi) :: infolp
10428 INTEGER(mpi) :: nfit
10429 INTEGER(mpl) :: imoff
10430#endif
10431
10432 REAL(mpd) :: stp
10433 REAL(mpd) :: dratio
10434 REAL(mpd) :: dwmean
10435 REAL(mpd) :: db
10436 REAL(mpd) :: db1
10437 REAL(mpd) :: db2
10438 REAL(mpd) :: dbdot
10439 REAL(mpd) :: dbsig
10440 LOGICAL :: btest
10441 LOGICAL :: warner
10442 LOGICAL :: warners
10443 LOGICAL :: warnerss
10444 LOGICAL :: warners3
10445 LOGICAL :: lsflag
10446 CHARACTER (LEN=7) :: cratio
10447 CHARACTER (LEN=7) :: cfacin
10448 CHARACTER (LEN=7) :: crjrat
10449 EXTERNAL avprds
10450 SAVE
10451 ! ...
10452
10453 ! Printout of algorithm for solution and important parameters ------
10454
10455 lun=lunlog ! log file
10456
10457 DO lunp=6,lunlog,lunlog-6
10458 WRITE(lunp,*) ' '
10459 WRITE(lunp,*) 'Solution algorithm: '
10460 WRITE(lunp,121) '=================================================== '
10461
10462 IF(metsol == 1) THEN
10463 WRITE(lunp,121) 'solution method:','matrix inversion'
10464 ELSE IF(metsol == 2) THEN
10465 WRITE(lunp,121) 'solution method:','diagonalization'
10466 ELSE IF(metsol == 3) THEN
10467 WRITE(lunp,121) 'solution method:','decomposition'
10468 ELSE IF(metsol == 4) THEN
10469 WRITE(lunp,121) 'solution method:', 'minres (Paige/Saunders)'
10470 ELSE IF(metsol == 5) THEN
10471 WRITE(lunp,121) 'solution method:', 'minres-qlp (Choi/Paige/Saunders)'
10472 IF(mrmode == 1) THEN
10473 WRITE(lunp,121) ' ', ' using QR factorization' ! only QR
10474 ELSE IF(mrmode == 2) THEN
10475 WRITE(lunp,121) ' ', ' using QLP factorization' ! only QLP
10476 ELSE
10477 WRITE(lunp,121) ' ', ' using QR and QLP factorization' ! QR followed by QLP
10478 WRITE(lunp,123) 'transition condition', mrtcnd
10479 END IF
10480 ELSE IF(metsol == 6) THEN
10481 WRITE(lunp,121) 'solution method:', &
10482 'gmres (generalized minimzation of residuals)'
10483#ifdef LAPACK64
10484 ELSE IF(metsol == 7) THEN
10485 IF (nagb > nvgb) THEN
10486 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSPTRF)'
10487 ELSE
10488 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPPTRF)'
10489 ENDIF
10490 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10491 ELSE IF(metsol == 8) THEN
10492 IF (nagb > nvgb) THEN
10493 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DSYTRF)'
10494 ELSE
10495 WRITE(lunp,121) 'solution method:', 'LAPACK factorization (DPOTRF)'
10496 ENDIF
10497 IF(ilperr == 1) WRITE(lunp,121) ' ', 'with error calculation (D??TRI)'
10498#ifdef PARDISO
10499 ELSE IF(metsol == 9) THEN
10500 IF (matbsz < 2) THEN
10501 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (CSR3))'
10502 ELSE
10503 WRITE(lunp,121) 'solution method:', 'Intel oneMKL PARDISO (sparse matrix (BSR3))'
10504 ENDIF
10505#endif
10506#endif
10507 END IF
10508 WRITE(lunp,123) 'convergence limit at Delta F=',dflim
10509 WRITE(lunp,122) 'maximum number of iterations=',mitera
10510 matrit=min(matrit,mitera)
10511 IF(matrit > 1) THEN
10512 WRITE(lunp,122) 'matrix recalculation up to ',matrit, '. iteration'
10513 END IF
10514 IF(metsol >= 4.AND.metsol < 7) THEN
10515 IF(matsto == 1) THEN
10516 WRITE(lunp,121) 'matrix storage:','full'
10517 ELSE IF(matsto == 2) THEN
10518 WRITE(lunp,121) 'matrix storage:','sparse'
10519 END IF
10520 WRITE(lunp,122) 'pre-con band-width parameter=',mbandw
10521 IF(mbandw == 0) THEN
10522 WRITE(lunp,121) 'pre-conditioning:','default'
10523 ELSE IF(mbandw < 0) THEN
10524 WRITE(lunp,121) 'pre-conditioning:','none!'
10525 ELSE IF(mbandw > 0) THEN
10526 IF(lprecm > 0) THEN
10527 WRITE(lunp,121) 'pre-conditioning=','skyline-matrix (rank preserving)'
10528 ELSE
10529 WRITE(lunp,121) 'pre-conditioning=','band-matrix'
10530 ENDIF
10531 END IF
10532 END IF
10533 IF(regpre == 0.0_mpd.AND.npresg == 0) THEN
10534 WRITE(lunp,121) 'using pre-sigmas:','no'
10535 ELSE
10536 ! FIXME: NPRESG contains parameters that failed the 'entries' cut...
10537 WRITE(lunp,124) 'pre-sigmas defined for', &
10538 REAL(100*npresg,mps)/REAL(nvgb,mps),' % of variable parameters'
10539 WRITE(lunp,123) 'default pre-sigma=',regpre
10540 END IF
10541 IF(nregul == 0) THEN
10542 WRITE(lunp,121) 'regularization:','no'
10543 ELSE
10544 WRITE(lunp,121) 'regularization:','yes'
10545 WRITE(lunp,123) 'regularization factor=',regula
10546 END IF
10547
10548 IF(chicut /= 0.0) THEN
10549 WRITE(lunp,121) 'Chi square cut equiv 3 st.dev applied'
10550 WRITE(lunp,123) '... in first iteration with factor',chicut
10551 WRITE(lunp,123) '... in second iteration with factor',chirem
10552 WRITE(lunp,121) ' (reduced by sqrt in next iterations)'
10553 END IF
10554 IF(iscerr > 0) THEN
10555 WRITE(lunp,121) 'Scaling of measurement errors applied'
10556 WRITE(lunp,123) '... factor for "global" measuements',dscerr(1)
10557 WRITE(lunp,123) '... factor for "local" measuements',dscerr(2)
10558 END IF
10559 IF(lhuber /= 0) THEN
10560 WRITE(lunp,122) 'Down-weighting of outliers in', lhuber,' iterations'
10561 WRITE(lunp,123) 'Cut on downweight fraction',dwcut
10562 END IF
10563
10564
10565121 FORMAT(1x,a40,3x,a)
10566122 FORMAT(1x,a40,3x,i0,a)
10567123 FORMAT(1x,a40,2x,e9.2)
10568124 FORMAT(1x,a40,3x,f5.1,a)
10569 END DO
10570
10571 ! initialization of iterations -------------------------------------
10572
10573 iitera=0
10574 nsol =0 ! counter for solutions
10575 info =0
10576 lsinfo=0
10577 stp =0.0_mpd
10578 stepl =real(stp,mps)
10579 concut=1.0e-12 ! initial constraint accuracy
10580 concu2=1.0e-06 ! constraint accuracy
10581 icalcm=1 ! require matrix calculation
10582 iterat=0 ! iteration counter
10583 iterat=-1
10584 litera=-2
10585 nloopsol=0 ! (new) solution from this nloopn
10586 nrej=0 ! reset number of rejects
10587 IF(metsol == 1) THEN
10588 wolfc2=0.5 ! not accurate
10589 minf=1
10590 ELSE IF(metsol == 2) THEN
10591 wolfc2=0.5 ! not acurate
10592 minf=2
10593 ELSE IF(metsol == 3) THEN
10594 wolfc2=0.5 ! not acurate
10595 minf=1
10596 ELSE IF(metsol == 4) THEN
10597 wolfc2=0.1 ! accurate
10598 minf=3
10599 ELSE IF(metsol == 5) THEN
10600 wolfc2=0.1 ! accurate
10601 minf=3
10602 ELSE IF(metsol == 6) THEN
10603 wolfc2=0.1 ! accurate
10604 minf=3
10605 ELSE
10606 wolfc2=0.5 ! not accurate
10607 minf=1
10608 END IF
10609
10610 ! check initial feasibility of constraint equations ----------------
10611
10612 WRITE(*,*) ' '
10613 IF(nofeas == 0) THEN ! make parameter feasible
10614 WRITE(lunlog,*) 'Checking feasibility of parameters:'
10615 WRITE(*,*) 'Checking feasibility of parameters:'
10616 CALL feasib(concut,iact) ! check feasibility
10617 IF(iact /= 0) THEN ! done ...
10618 WRITE(*,102) concut
10619 WRITE(*,*) ' parameters are made feasible'
10620 WRITE(lunlog,102) concut
10621 WRITE(lunlog,*) ' parameters are made feasible'
10622 ELSE ! ... was OK
10623 WRITE(*,*) ' parameters are feasible (i.e. satisfy constraints)'
10624 WRITE(lunlog,*) ' parameters are feasible (i.e. satisfy constraints)'
10625 END IF
10626 concut=concu2 ! cut for constraint check
10627 END IF
10628 iact=1 ! set flag for new data loop
10629 nofeas=0 ! set check-feasibility flag
10630
10631 WRITE(*,*) ' '
10632 WRITE(*,*)'Reading files and accumulating vectors/matrices ...'
10633 WRITE(*,*) ' '
10634 IF(monpg1>0) THEN
10635 WRITE(lunlog,*)
10636 WRITE(lunlog,*)'Reading files and accumulating vectors/matrices ...'
10637 WRITE(lunlog,*)
10638 END IF
10639
10640 rstart=etime(ta)
10641 iterat=-1
10642 litera= 0
10643 jcalcm=-1
10644 iagain= 0
10645
10646 icalcm=1
10647
10648 ! Block 1: data loop with vector (and matrix) calculation ----------
10649
10650 DO
10651 IF(iterat >= 0) THEN
10652 lcalcm=jcalcm+3 ! mode (1..4) of last loop
10653 IF(jcalcm+1 /= 0) THEN
10654 IF(iterat == 0) THEN
10655 CALL ploopa(6) ! header
10656 CALL ploopb(6)
10657 CALL ploopa(lunlog) ! iteration line
10658 CALL ploopb(lunlog)
10659 iterat=1
10660 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10661 ELSE
10662 IF(iterat /= litera) THEN
10663 CALL ploopb(6)
10664 ! CALL PLOOPA(LUNLOG)
10665 CALL ploopb(lunlog)
10666 litera=iterat
10667 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,delfun) ! fcn-value (with expected)
10668 IF(metsol == 4 .OR. metsol == 5) THEN ! extend to 6, i.e. GMRES?
10669 CALL gmpxy(2,real(iterat,mps),real(iitera,mps)) ! MINRES iterations
10670 END IF
10671 ELSE
10672 CALL ploopc(6) ! sub-iteration line
10673 CALL ploopc(lunlog)
10674 CALL gmpxyd(1,real(nloopn,mps),real(fvalue,mps),0.5,0.) ! fcn-value graph (no Delta)
10675 END IF
10676 END IF
10677 ELSE
10678 CALL ploopd(6) ! solution line
10679 CALL ploopd(lunlog)
10680 END IF
10681 rstart=etime(ta)
10682 ! CHK
10683 IF (iabs(jcalcm) <= 1) THEN
10684 idx=jcalcm+4
10685 times(idx )=(times(idx )*times(idx+3)+deltim) /(times(idx+3)+1.0)
10686 times(idx+3)= times(idx+3)+1.0
10687 END IF
10688 END IF
10689 jcalcm=icalcm
10690
10691 IF(icalcm >= 0) THEN ! ICALCM = +1 & 0
10692 CALL loopn ! data loop
10693 CALL addcst ! constraints
10694 lrej=nrej
10695 nrej=sum(nrejec) ! total number of rejects
10696 IF(3*nrej > nrecal) THEN
10697 WRITE(*,*) ' '
10698 WRITE(*,*) 'Data records rejected in previous loop: '
10699 CALL prtrej(6)
10700 WRITE(*,*) 'Too many rejects (>33.3%) - stop'
10701 CALL peend(26,'Aborted, too many rejects')
10702 stop
10703 END IF
10704 ! fill second half (j>i) of global matrix for extended storage, experimental
10705 IF (icalcm == 1.AND.mextnd > 0) CALL mhalf2()
10706 END IF
10707 ! Block 2: new iteration with calculation of solution --------------
10708 IF(abs(icalcm) == 1) THEN ! ICALCM = +1 & -1
10709 DO i=1,nagb
10710 globalcorrections(i)=globalvector(i) ! copy rhs
10711 END DO
10712 DO i=1,nvgb
10713 itgbi=globalparvartototal(i)
10714 workspacelinesearch(i)=globalparameter(itgbi) ! copy X for line search
10715 END DO
10716
10717 iterat=iterat+1 ! increase iteration count
10718 IF(metsol == 1) THEN
10719 CALL minver ! inversion
10720 ELSE IF(metsol == 2) THEN
10721 CALL mdiags ! diagonalization
10722 ELSE IF(metsol == 3) THEN
10723 CALL mchdec ! decomposition
10724 ELSE IF(metsol == 4) THEN
10725 CALL mminrs ! MINRES
10726 ELSE IF(metsol == 5) THEN
10727 CALL mminrsqlp ! MINRES-QLP
10728 ELSE IF(metsol == 6) THEN
10729 WRITE(*,*) '... reserved for GMRES (not yet!)'
10730 CALL mminrs ! GMRES not yet
10731#ifdef LAPACK64
10732 ELSE IF(metsol == 7) THEN
10733 CALL mdptrf ! LAPACK (packed storage)
10734 ELSE IF(metsol == 8) THEN
10735 CALL mdutrf ! LAPACK (unpacked storage)
10736#ifdef PARDISO
10737 ELSE IF(metsol == 9) THEN
10738 CALL mspardiso ! Intel oneMKL PARDISO (sparse matrix (CSR3, upper triangle))
10739#endif
10740#endif
10741 END IF
10742 nloopsol=nloopn ! (new) solution for this nloopn
10743
10744 ! check feasibility and evtl. make step vector feasible
10745
10746 DO i=1,nvgb
10747 itgbi=globalparvartototal(i)
10748 globalparcopy(itgbi)=globalparameter(itgbi) ! save
10749 globalparameter(itgbi)=globalparameter(itgbi)+globalcorrections(i) ! update
10750 END DO
10751 CALL feasib(concut,iact) ! improve constraints
10752 concut=concu2 ! new cut for constraint check
10753 DO i=1,nvgb
10754 itgbi=globalparvartototal(i)
10755 globalcorrections(i)=globalparameter(itgbi)-globalparcopy(itgbi) ! feasible stp
10756 globalparameter(itgbi)=globalparcopy(itgbi) ! restore
10757 END DO
10758
10761 db2=dbdot(nvgb,globalvector,globalvector)
10762 delfun=real(db,mps)
10763 angras=real(db/sqrt(db1*db2),mps)
10764 dbsig=16.0_mpd*sqrt(max(db1,db2))*epsilon(db) ! significant change
10765
10766 ! do line search for this iteration/solution ?
10767 ! lsearch >2: all, =2: all with (next) chicut =1., =1: last, <1: none
10768 lsflag=(lsearch > 2 .OR. (lsearch == 2 .AND. chicut < 2.25) .OR. &
10769 (lsearch == 1 .AND. chicut < 2.25 .AND. (delfun <= dflim .OR. iterat >= mitera)))
10770 lsflag=lsflag .AND. (db > dbsig) ! require significant change
10771 IF (lsflag) THEN
10772 ! initialize line search based on slopes and prepare next
10773 CALL ptldef(wolfc2, 10.0, minf,10)
10774 IF(metsol == 1) THEN
10775 wolfc2=0.5 ! not accurate
10776 minf=3
10777 ELSE IF(metsol == 2) THEN
10778 wolfc2=0.5 ! not acurate
10779 minf=3
10780 ELSE IF(metsol == 3) THEN
10781 wolfc2=0.5 ! not acurate
10782 minf=3
10783 ELSE IF(metsol == 4) THEN
10784 wolfc2=0.1 ! accurate
10785 minf=4
10786 ELSE IF(metsol == 5) THEN
10787 wolfc2=0.1 ! accurate
10788 minf=4
10789 ELSE IF(metsol == 6) THEN
10790 wolfc2=0.1 ! accurate
10791 minf=4
10792 ELSE
10793 wolfc2=0.5 ! not accurate
10794 minf=3
10795 END IF
10796 ENDIF
10797
10798 ! change significantly negative ?
10799 IF(db <= -dbsig) THEN
10800 WRITE(*,*) 'Function not decreasing:',db
10801 IF(db > -1.0e-3_mpd) THEN ! 100311, VB/CK: allow some margin for numerics
10802 iagain=iagain+1
10803 IF (iagain <= 1) THEN
10804 WRITE(*,*) '... again matrix calculation'
10805 icalcm=1
10806 cycle
10807 ELSE
10808 WRITE(*,*) '... aborting iterations'
10809 GO TO 90
10810 END IF
10811 ELSE
10812 WRITE(*,*) '... stopping iterations'
10813 iagain=-1
10814 GO TO 90
10815 END IF
10816 ELSE
10817 iagain=0
10818 END IF
10819 icalcm=0 ! switch
10820 ENDIF
10821 ! Block 3: line searching ------------------------------------------
10822
10823 IF(icalcm+2 == 0) EXIT
10824 IF (lsflag) THEN
10825 CALL ptline(nvgb,workspacelinesearch, & ! current parameter values
10826 flines, & ! chi^2 function value
10827 globalvector, & ! gradient
10828 globalcorrections, & ! step vector stp
10829 stp, & ! returned step factor
10830 info) ! returned information
10831 ! WRITE(*,*) 'PTLINE returns INFO, STP=',INFO, STP
10832 ELSE ! skip line search
10833 info=10
10834 stepl=1.0
10835 IF (nloopn == nloopsol) THEN ! new solution: update corrections
10837 ENDIF
10838 ENDIF
10839 lsinfo=info
10840
10841 stepl=real(stp,mps)
10842 nan=0
10843 DO i=1,nvgb
10844 itgbi=globalparvartototal(i)
10845 IF ((.NOT.(workspacelinesearch(i) <= 0.0_mpd)).AND. &
10846 (.NOT.(workspacelinesearch(i) > 0.0_mpd))) nan=nan+1
10847 globalparameter(itgbi)=workspacelinesearch(i) ! current parameter values
10848 END DO
10849
10850 IF (nan > 0) THEN
10851 WRITE(*,*) 'Result vector containes ', nan,' NaNs - stop'
10852 CALL peend(25,'Aborted, result vector contains NaNs')
10853 stop
10854 END IF
10855
10856 ! subito exit, if required -----------------------------------------
10857
10858 IF(isubit /= 0) THEN ! subito
10859 WRITE(*,*) 'Subito! Exit after first step.'
10860 GO TO 90
10861 END IF
10862
10863 IF(info == 0) THEN
10864 WRITE(*,*) 'INFO=0 should not happen (line search input err)'
10865 IF (iagain <= 0) THEN
10866 icalcm=1
10867 cycle
10868 ENDIF
10869 END IF
10870 IF(info < 0 .OR. nloopn == nloopsol) cycle
10871 ! Block 4: line search convergence ---------------------------------
10872
10873 CALL ptlprt(lunlog)
10874 CALL feasib(concut,iact) ! check constraints
10875 IF(iact /= 0.OR.chicut > 1.0) THEN
10876 icalcm=-1
10877 IF(iterat < matrit) icalcm=+1
10878 cycle ! iterate
10879 END IF
10880 IF(delfun <= dflim) GO TO 90 ! convergence
10881 IF(iterat >= mitera) GO TO 90 ! ending
10882 icalcm=-1
10883 IF(iterat < matrit) icalcm=+1
10884 cycle ! next iteration
10885
10886 ! Block 5: iteration ending ----------------------------------------
10887
1088890 icalcm=-2
10889 END DO
10890 IF(sum(nrejec) /= 0) THEN
10891 WRITE(*,*) ' '
10892 WRITE(*,*) 'Data records rejected in last loop: '
10893 CALL prtrej(6)
10894 END IF
10895
10896 ! monitoring of residuals
10897 IF (imonit > 0 .AND. btest(imonit,1)) CALL monres
10898 IF (lunmon > 0) CLOSE(unit=lunmon)
10899
10900 ! construct inverse from diagonalization
10901 IF(metsol == 2) CALL zdiags
10902
10903 IF(ALLOCATED(workspacediag)) THEN ! provide parameter errors?
10904#ifdef LAPACK64
10905 IF (metsol == 7.OR.metsol == 8) THEN
10906 ! inverse from factorization
10907 ! loop over blocks (multiple blocks only with elimination !)
10908 DO ib=1,npblck
10909 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10910 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
10911 icoff=vecparblockconoffsets(ib) ! constraint offset for block
10912 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
10913 imoff=globalrowoffsets(ipoff+1)+ipoff ! block offset in global matrix
10914 nfit=npar+ncon; IF (icelim > 0) nfit=npar-ncon ! number of fit parameters in block
10915 IF (nfit > npar) THEN
10916 ! monitor progress
10917 IF(monpg1 > 0) THEN
10918 WRITE(lunlog,*) 'Inverse of global matrix from LDLt factorization'
10920 END IF
10921 IF (matsto == 1) THEN
10922 !$POMP INST BEGIN(dsptri)
10923#ifdef SCOREP_USER_ENABLE
10924 scorep_user_region_by_name_begin("UR_dsptri", scorep_user_region_type_common)
10925#endif
10926 CALL dsptri('U',int(nfit,mpl),globalmatd(imoff+1:),lapackipiv(ipoff+1:),workspaced,infolp)
10927 IF(infolp /= 0) print *, ' DSPTRI failed: ', infolp
10928#ifdef SCOREP_USER_ENABLE
10929 scorep_user_region_by_name_end("UR_dsptri")
10930#endif
10931 !$POMP INST END(dsptri)
10932 IF(monpg1 > 0) CALL monend()
10933 ELSE
10934 !$POMP INST BEGIN(dsytri)
10935#ifdef SCOREP_USER_ENABLE
10936 scorep_user_region_by_name_begin("UR_dsytri", scorep_user_region_type_common)
10937#endif
10938 CALL dsytri('U',int(nfit,mpl),globalmatd(imoff+1:),int(nfit,mpl),&
10939 lapackipiv(ipoff+1:),workspaced,infolp)
10940 IF(infolp /= 0) print *, ' DSYTRI failed: ', infolp
10941#ifdef SCOREP_USER_ENABLE
10942 scorep_user_region_by_name_end("UR_dsytri")
10943#endif
10944 !$POMP INST END(dsytri)
10945 IF(monpg1 > 0) CALL monend()
10946 END IF
10947 ELSE
10948 IF(monpg1 > 0) THEN
10949 WRITE(lunlog,*) 'Inverse of global matrix from LLt factorization'
10951 END IF
10952 IF (matsto == 1) THEN
10953 !$POMP INST BEGIN(dpptri)
10954#ifdef SCOREP_USER_ENABLE
10955 scorep_user_region_by_name_begin("UR_dpptri", scorep_user_region_type_common)
10956#endif
10957 CALL dpptri('U',int(nfit,mpl),globalmatd(imoff+1:),infolp)
10958 IF(infolp /= 0) print *, ' DPPTRI failed: ', infolp
10959#ifdef SCOREP_USER_ENABLE
10960 scorep_user_region_by_name_end("UR_dpptri")
10961#endif
10962 !$POMP INST END(dpptri)
10963 ELSE
10964 !$POMP INST BEGIN(dpotri)
10965#ifdef SCOREP_USER_ENABLE
10966 scorep_user_region_by_name_begin("UR_dpotri", scorep_user_region_type_common)
10967#endif
10968 CALL dpotri('U',int(nfit,mpl),globalmatd(imoff+1:),int(npar,mpl),infolp)
10969 IF(infolp /= 0) print *, ' DPOTRI failed: ', infolp
10970#ifdef SCOREP_USER_ENABLE
10971 scorep_user_region_by_name_end("UR_dpotri")
10972#endif
10973 !$POMP INST END(dpotri)
10974 END IF
10975 IF(monpg1 > 0) CALL monend()
10976 END IF
10977 END DO
10978 END IF
10979#endif
10980 !use elimination for constraints ?
10981 IF(nfgb < nvgb) THEN
10982 ! extend, transform matrix
10983 ! loop over blocks
10984 DO ib=1,npblck
10985 ipoff=matparblockoffsets(1,ib) ! parameter offset for block
10986 npar=matparblockoffsets(1,ib+1)-ipoff ! number of parameters in block
10987 icoff=vecparblockconoffsets(ib) ! constraint offset for block
10988 ncon=vecparblockconoffsets(ib+1)-icoff ! number of constraints in block
10989 DO i=npar-ncon+1,npar
10990 ioff=globalrowoffsets(i+ipoff)+ipoff
10991 globalmatd(ioff+1:ioff+i)=0.0_mpd
10992 END DO
10993 END DO
10994 ! monitor progress
10995 IF(monpg1 > 0) THEN
10996 WRITE(lunlog,*) 'Expansion of global matrix (A->Q*A*Q^t)'
10998 END IF
10999 IF(icelim < 2) THEN
11000 CALL qlssq(avprds,globalmatd,size(globalmatd,kind=mpl),globalrowoffsets,.false.) ! Q*A*Q^t
11001#ifdef LAPACK64
11002 ELSE ! unpack storage, use LAPACK
11003 CALL lpavat(.false.)
11004#endif
11005 END IF
11006 IF(monpg1 > 0) CALL monend()
11007 END IF
11008 END IF
11009
11010 dwmean=sumndf/real(ndfsum,mpd)
11011 dratio=fvalue/dwmean/real(ndfsum-nfgb,mpd)
11012 catio=real(dratio,mps)
11013 IF(nloopn /= 1.AND.lhuber /= 0) THEN
11014 catio=catio/0.9326 ! correction Huber downweighting (in global chi2)
11015 END IF
11016 mrati=nint(100.0*catio,mpi)
11017
11018 DO lunp=6,lunlog,lunlog-6
11019 WRITE(lunp,*) ' '
11020 IF (nfilw <= 0) THEN
11021 WRITE(lunp,*) 'Sum(Chi^2)/Sum(Ndf) =',fvalue
11022 WRITE(lunp,*) ' / (',ndfsum,'-',nfgb,')'
11023 WRITE(lunp,*) ' =',dratio
11024 ELSE
11025 WRITE(lunp,*) 'Sum(W*Chi^2)/Sum(Ndf)/<W> =',fvalue
11026 WRITE(lunp,*) ' / (',ndfsum,'-', nfgb,')'
11027 WRITE(lunp,*) ' /',dwmean
11028 WRITE(lunp,*) ' =',dratio
11029 END IF
11030 WRITE(lunp,*) ' '
11031 IF(nloopn /= 1.AND.lhuber /= 0) WRITE(lunp,*) &
11032 ' with correction for down-weighting ',catio
11033 END DO
11034 nrej=sum(nrejec) ! total number of rejects
11035
11036 ! ... the end with exit code ???????????????????????????????????????
11037
11038 ! WRITE(*,199) ! write exit code
11039 ! + '-----------------------------------------------------------'
11040 ! IF(ITEXIT.EQ.0) WRITE(*,199)
11041 ! + 'Exit code = 0: Convergence reached'
11042 ! IF(ITEXIT.EQ.1) WRITE(*,199)
11043 ! + 'Exit code = 1: No improvement in last iteration'
11044 ! IF(ITEXIT.EQ.2) WRITE(*,199)
11045 ! + 'Exit code = 2: Maximum number of iterations reached'
11046 ! IF(ITEXIT.EQ.3) WRITE(*,199)
11047 ! + 'Exit code = 3: Failure'
11048 ! WRITE(*,199)
11049 ! + '-----------------------------------------------------------'
11050 ! WRITE(*,199) ' '
11051
11052
11053 nrati=nint(10000.0*real(nrej,mps)/real(nrecal,mps),mpi)
11054 WRITE(crjrat,197) 0.01_mpd*real(nrati,mpd)
11055 nfaci=nint(100.0*sqrt(catio),mpi)
11056
11057 WRITE(cratio,197) 0.01_mpd*real(mrati,mpd)
11058 WRITE(cfacin,197) 0.01_mpd*real(nfaci,mpd)
11059
11060 warner=.false. ! warnings
11061 IF(mrati < 90.OR.mrati > 110) warner=.true.
11062 IF(nrati > 100) warner=.true.
11063 IF(ncgbe /= 0) warner=.true.
11064 warners = .false. ! severe warnings
11065 IF(nalow /= 0) warners=.true.
11066 warnerss = .false. ! more severe warnings
11067 IF(nmiss1 /= 0) warnerss=.true.
11068 IF(iagain /= 0) warnerss=.true.
11069 IF(ndefec /= 0) warnerss=.true.
11070 IF(ndefpg /= 0) warnerss=.true.
11071 warners3 = .false. ! more severe warnings
11072 IF(nrderr /= 0) warners3=.true.
11073
11074 IF(warner.OR.warners.OR.warnerss.Or.warners3) THEN
11075 WRITE(*,199) ' '
11076 WRITE(*,199) ' '
11077 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
11078 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
11079 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
11080 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
11081 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
11082 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
11083 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
11084
11085 IF(mrati < 90.OR.mrati > 110) THEN
11086 WRITE(*,199) ' '
11087 WRITE(*,*) ' Chi^2/Ndf = ',cratio, ' (should be close to 1)'
11088 WRITE(*,*) ' => multiply all input standard ', &
11089 'deviations by factor',cfacin
11090 END IF
11091
11092 IF(nrati > 100) THEN
11093 WRITE(*,199) ' '
11094 WRITE(*,*) ' Fraction of rejects =',crjrat,' %', &
11095 ' (should be far below 1 %)'
11096 WRITE(*,*) ' => please provide correct mille data'
11097 CALL chkrej ! check (and print) rejection details
11098 END IF
11099
11100 IF(iagain /= 0) THEN
11101 WRITE(*,199) ' '
11102 WRITE(*,*) ' Matrix not positiv definite '// &
11103 '(function not decreasing)'
11104 WRITE(*,*) ' => please provide correct mille data'
11105 END IF
11106
11107 IF(ndefec /= 0) THEN
11108 WRITE(*,199) ' '
11109 WRITE(*,*) ' Rank defect =',ndefec, &
11110 ' for global matrix, should be 0'
11111 WRITE(*,*) ' => please provide correct mille data'
11112 END IF
11113
11114 IF(ndefpg /= 0) THEN
11115 WRITE(*,199) ' '
11116 WRITE(*,*) ' Rank defect for',ndefpg, &
11117 ' parameter groups, should be 0'
11118 WRITE(*,*) ' => please provide correct mille data'
11119 END IF
11120
11121 IF(nmiss1 /= 0) THEN
11122 WRITE(*,199) ' '
11123 WRITE(*,*) ' Rank defect =',nmiss1, &
11124 ' for constraint equations, should be 0'
11125 WRITE(*,*) ' => please correct constraint definition'
11126 END IF
11127
11128 IF(ncgbe /= 0) THEN
11129 WRITE(*,199) ' '
11130 WRITE(*,*) ' Number of empty constraints =',ncgbe, ', should be 0'
11131 WRITE(*,*) ' => please check constraint definition, mille data'
11132 END IF
11133
11134 IF(nxlow /= 0) THEN
11135 WRITE(*,199) ' '
11136 WRITE(*,*) ' Possible rank defects =',nxlow, ' for global matrix'
11137 WRITE(*,*) ' (too few accepted entries)'
11138 WRITE(*,*) ' => please check mille data and ENTRIES cut'
11139 END IF
11140
11141 IF(nalow /= 0) THEN
11142 WRITE(*,199) ' '
11143 WRITE(*,*) ' Possible bad elements =',nalow, ' in global vector'
11144 WRITE(*,*) ' (toos few accepted entries)'
11145 IF(ipcntr > 0) WRITE(*,*) ' (indicated in millepede.res by counts<0)'
11146 WRITE(*,*) ' => please check mille data and ENTRIES cut'
11147 END IF
11148
11149 IF(nrderr /= 0) THEN
11150 WRITE(*,199) ' '
11151 WRITE(*,*) ' Binary file(s) with read errors =',nrderr, ' (treated as EOF)'
11152 WRITE(*,*) ' => please check mille data'
11153 END IF
11154
11155 WRITE(*,199) ' '
11156 WRITE(*,199) 'WarningWarningWarningWarningWarningWarningWarningWarningWar'
11157 WRITE(*,199) 'arningWarningWarningWarningWarningWarningWarningWarningWarn'
11158 WRITE(*,199) 'rningWarningWarningWarningWarningWarningWarningWarningWarni'
11159 WRITE(*,199) 'ningWarningWarningWarningWarningWarningWarningWarningWarnin'
11160 WRITE(*,199) 'ingWarningWarningWarningWarningWarningWarningWarningWarning'
11161 WRITE(*,199) 'ngWarningWarningWarningWarningWarningWarningWarningWarningW'
11162 WRITE(*,199) 'gWarningWarningWarningWarningWarningWarningWarningWarningWa'
11163 WRITE(*,199) ' '
11164
11165 ENDIF
11166
11167 CALL mend ! modul ending
11168
11169 ! ------------------------------------------------------------------
11170
11171 IF(metsol == 1) THEN
11172
11173 ELSE IF(metsol == 2) THEN
11174 ! CALL zdiags moved up (before qlssq)
11175 ELSE IF(metsol == 3) THEN
11176 ! decomposition - nothing foreseen yet
11177 ELSE IF(metsol == 4 .OR. metsol == 5) THEN
11178 ! errors and correlations from MINRES
11179 DO k=1,mnrsel
11180 labelg=lbmnrs(k)
11181 IF(labelg == 0) cycle
11182 itgbi=inone(labelg)
11183 ivgbi=0
11184 IF(itgbi /= 0) ivgbi=globalparlabelindex(2,itgbi)
11185 IF(ivgbi < 0) ivgbi=0
11186 IF(ivgbi == 0) cycle
11187 ! determine error and global correlation for parameter IVGBI
11188 IF (metsol == 4) THEN
11189 CALL solglo(ivgbi)
11190 ELSE
11191 CALL solgloqlp(ivgbi)
11192 ENDIF
11193 END DO
11194
11195 ELSE IF(metsol == 6) THEN
11196
11197#ifdef LAPACK64
11198 ELSE IF(metsol == 7) THEN
11199 ! LAPACK - nothing foreseen yet
11200#endif
11201 END IF
11202
11203 CALL prtglo ! print result
11204
11205 IF (warners3) THEN
11206 CALL peend(4,'Ended with severe warnings (bad binary file(s))')
11207 ELSE IF (warnerss) THEN
11208 CALL peend(3,'Ended with severe warnings (bad global matrix)')
11209 ELSE IF (warners) THEN
11210 CALL peend(2,'Ended with severe warnings (insufficient measurements)')
11211 ELSE IF (warner) THEN
11212 CALL peend(1,'Ended with warnings (bad measurements)')
11213 ELSE
11214 CALL peend(0,'Ended normally')
11215 END IF
11216
11217102 FORMAT(' Call FEASIB with cut=',g10.3)
11218 ! 103 FORMAT(1X,A,G12.4)
11219197 FORMAT(f7.2)
11220199 FORMAT(7x,a)
11221END SUBROUTINE xloopn ! standard solution
11222
11223
11228
11229SUBROUTINE chkrej
11230 USE mpmod
11231 USE mpdalc
11232
11233 IMPLICIT NONE
11234 INTEGER(mpi) :: i
11235 INTEGER(mpi) :: kfl
11236 INTEGER(mpi) :: kmin
11237 INTEGER(mpi) :: kmax
11238 INTEGER(mpi) :: nrc
11239 INTEGER(mpl) :: nrej
11240
11241 REAL(mps) :: fmax
11242 REAL(mps) :: fmin
11243 REAL(mps) :: frac
11244
11245 REAL(mpd) :: sumallw
11246 REAL(mpd) :: sumrejw
11247
11248 sumallw=0.; sumrejw=0.;
11249 kmin=0; kmax=0;
11250 fmax=-1.; fmin=2;
11251
11252 DO i=1,nfilb
11253 kfl=kfd(2,i)
11254 nrc=-kfd(1,i)
11255 IF (nrc > 0) THEN
11256 nrej=nrc-jfd(kfl)
11257 sumallw=sumallw+real(nrc,mpd)*wfd(kfl)
11258 sumrejw=sumrejw+real(nrej,mpd)*wfd(kfl)
11259 frac=real(nrej,mps)/real(nrc,mps)
11260 IF (frac > fmax) THEN
11261 kmax=kfl
11262 fmax=frac
11263 END IF
11264 IF (frac < fmin) THEN
11265 kmin=kfl
11266 fmin=frac
11267 END IF
11268 END IF
11269 END DO
11270 IF (nfilw > 0) &
11271 WRITE(*,"(' Weighted fraction =',F8.2,' %')") 100.*sumrejw/sumallw
11272 IF (nfilb > 1) THEN
11273 WRITE(*,"(' File with max. fraction ',I6,' :',F8.2,' %')") kmax, 100.*fmax
11274 WRITE(*,"(' File with min. fraction ',I6,' :',F8.2,' %')") kmin, 100.*fmin
11275 END IF
11276
11277END SUBROUTINE chkrej
11278
11292
11293SUBROUTINE filetc
11294 USE mpmod
11295 USE mpdalc
11296
11297 IMPLICIT NONE
11298 INTEGER(mpi) :: i
11299 INTEGER(mpi) :: ia
11300 INTEGER(mpi) :: iargc
11301 INTEGER(mpi) :: ib
11302 INTEGER(mpi) :: ie
11303 INTEGER(mpi) :: ierrf
11304 INTEGER(mpi) :: ieq
11305 INTEGER(mpi) :: ifilb
11306 INTEGER(mpi) :: ioff
11307 INTEGER(mpi) :: iopt
11308 INTEGER(mpi) :: ios
11309 INTEGER(mpi) :: iosum
11310 INTEGER(mpi) :: it
11311 INTEGER(mpi) :: k
11312 INTEGER(mpi) :: mat
11313 INTEGER(mpi) :: nab
11314 INTEGER(mpi) :: nline
11315 INTEGER(mpi) :: npat
11316 INTEGER(mpi) :: ntext
11317 INTEGER(mpi) :: nu
11318 INTEGER(mpi) :: nuf
11319 INTEGER(mpi) :: nums
11320 INTEGER(mpi) :: nufile
11321 INTEGER(mpi) :: lenfileInfo
11322 INTEGER(mpi) :: lenFileNames
11323 INTEGER(mpi) :: matint
11324 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: vecfileInfo
11325 INTEGER(mpi), DIMENSION(:,:), ALLOCATABLE :: tempArray
11326 INTEGER(mpl) :: rows
11327 INTEGER(mpl) :: cols
11328 INTEGER(mpl) :: newcols
11329 INTEGER(mpl) :: length
11330
11331 CHARACTER (LEN=1024) :: text
11332 CHARACTER (LEN=1024) :: fname
11333 CHARACTER (LEN=14) :: bite(3)
11334 CHARACTER (LEN=32) :: keystx
11335 INTEGER(mpi), PARAMETER :: mnum=100
11336 REAL(mpd) :: dnum(mnum)
11337
11338#ifdef READ_C_FILES
11339 INTERFACE
11340 SUBROUTINE initc(nfiles) BIND(c)
11341 USE iso_c_binding
11342 INTEGER(c_int), INTENT(IN), VALUE :: nfiles
11343 END SUBROUTINE initc
11344 END INTERFACE
11345#endif
11346
11347 SAVE
11348 DATA bite/'C_binary','text ','Fortran_binary'/
11349 ! ...
11350 CALL mstart('FILETC/X')
11351
11352 nuf=1 ! C binary is default
11353 DO i=1,8
11354 times(i)=0.0
11355 END DO
11356
11357 ! read command line options ----------------------------------------
11358
11359 filnam=' ' ! print command line options and find steering file
11360 DO i=1,iargc()
11361 IF(i == 1) THEN
11362 WRITE(*,*) ' '
11363 WRITE(*,*) 'Command line options: '
11364 WRITE(*,*) '--------------------- '
11365 END IF
11366 CALL getarg(i,text) ! get I.th text from command line
11367 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11368 WRITE(*,101) i,text(1:nab) ! echo print
11369 IF(text(ia:ia) /= '-') THEN
11370 nu=nufile(text(ia:ib)) ! inquire on file existence
11371 IF(nu == 2) THEN ! existing text file
11372 IF(filnam /= ' ') THEN
11373 WRITE(*,*) 'Second text file in command line - stop'
11374 CALL peend(12,'Aborted, second text file in command line')
11375 stop
11376 ELSE
11377 filnam=text
11378 END IF
11379 ELSE
11380 WRITE(*,*) 'Open error for file:',text(ia:ib),' - stop'
11381 CALL peend(16,'Aborted, open error for file')
11382 IF(text(ia:ia) /= '/') THEN
11383 CALL getenv('PWD',text)
11384 CALL rltext(text,ia,ib,nab)
11385 WRITE(*,*) 'PWD:',text(ia:ib)
11386 END IF
11387 stop
11388 END IF
11389 ELSE
11390 IF(index(text(ia:ib),'b') /= 0) THEN
11391 mdebug=3 ! debug flag
11392 WRITE(*,*) 'Debugging requested'
11393 END IF
11394 it=index(text(ia:ib),'t')
11395 IF(it /= 0) THEN
11396 ictest=1 ! internal test files
11397 ieq=index(text(ia+it:ib),'=')+it
11398 IF (it /= ieq) THEN
11399 IF (index(text(ia+ieq:ib),'SL0' ) /= 0) ictest=2
11400 IF (index(text(ia+ieq:ib),'SLE' ) /= 0) ictest=3
11401 IF (index(text(ia+ieq:ib),'BP' ) /= 0) ictest=4
11402 IF (index(text(ia+ieq:ib),'BRLF') /= 0) ictest=5
11403 IF (index(text(ia+ieq:ib),'BRLC') /= 0) ictest=6
11404 END IF
11405 END IF
11406 IF(index(text(ia:ib),'s') /= 0) isubit=1 ! like "subito"
11407 IF(index(text(ia:ib),'f') /= 0) iforce=1 ! like "force"
11408 IF(index(text(ia:ib),'c') /= 0) icheck=1 ! like "checkinput"
11409 IF(index(text(ia:ib),'C') /= 0) icheck=2 ! like "checkinput 2"
11410 END IF
11411 IF(i == iargc()) WRITE(*,*) '--------------------- '
11412 END DO
11413
11414
11415 ! create test files for option -t ----------------------------------
11416
11417 IF(ictest >= 1) THEN
11418 WRITE(*,*) ' '
11419 IF (ictest == 1) THEN
11420 CALL mptest ! 'wire chamber'
11421 ELSE
11422 CALL mptst2(ictest-2) ! 'silicon tracker'
11423 END IF
11424 IF(filnam == ' ') filnam='mp2str.txt'
11425 WRITE(*,*) ' '
11426 END IF
11427
11428 ! check default steering file with file-name "steerfile" -----------
11429
11430 IF(filnam == ' ') THEN ! check default steering file
11431 text='steerfile'
11432 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11433 nu=nufile(text(ia:ib)) ! inquire on file existence and type
11434 IF(nu > 0) THEN
11435 filnam=text
11436 ELSE
11437 CALL peend(10,'Aborted, no steering file')
11438 stop 'in FILETC: no steering file. .'
11439 END IF
11440 END IF
11441
11442
11443 ! open, read steering file:
11444 ! end
11445 ! fortranfiles
11446 ! cfiles
11447
11448
11449 CALL rltext(filnam,ia,ib,nfnam) ! return indices for non-blank area
11450 WRITE(*,*) ' '
11451 WRITE(*,*) 'Listing of steering file: ',filnam(1:nfnam)
11452 WRITE(*,*) '-------------------------'
11453 OPEN(10,file=filnam(1:nfnam),iostat=ios)
11454 IF(ios /= 0) THEN
11455 WRITE(*,*) 'Open error for steering file - stop'
11456 CALL peend(11,'Aborted, open error for steering file')
11457 IF(filnam(1:1) /= '/') THEN
11458 CALL getenv('PWD',text)
11459 CALL rltext(text,ia,ib,nab)
11460 WRITE(*,*) 'PWD:',text(ia:ib)
11461 END IF
11462 stop
11463 END IF
11464 ifile =0
11465 nfiles=0
11466
11467 lenfileinfo=2
11468 lenfilenames=0
11469 rows=6; cols=lenfileinfo
11470 CALL mpalloc(vecfileinfo,rows,cols,'file info from steering')
11471 nline=0
11472 DO
11473 READ(10,102,iostat=ierrf) text ! read steering file
11474 IF (ierrf < 0) EXIT ! eof
11475 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
11476 nline=nline+1
11477 IF(nline <= 50) THEN ! print up to 50 lines
11478 WRITE(*,101) nline,text(1:nab)
11479 IF(nline == 50) WRITE(*,*) ' ...'
11480 END IF
11481 IF(ia == 0) cycle ! skip empty lines
11482
11483 CALL rltext(text,ia,ib,nab) ! test content 'end'
11484 IF(ib == ia+2) THEN
11485 mat=matint(text(ia:ib),'end',npat,ntext)
11486 IF(mat == max(npat,ntext)) THEN ! exact matching
11487 text=' '
11488 CALL intext(text,nline)
11489 WRITE(*,*) ' end-statement after',nline,' text lines'
11490 EXIT
11491 END IF
11492 END IF
11493
11494 keystx='fortranfiles'
11495 mat=matint(text(ia:ib),keystx,npat,ntext)
11496 IF(mat == max(npat,ntext)) THEN ! exact matching
11497 nuf=3
11498 ! WRITE(*,*) 'Fortran files'
11499 cycle
11500 END IF
11501
11502 keystx='Cfiles'
11503 mat=matint(text(ia:ib),keystx,npat,ntext)
11504 IF(mat == max(npat,ntext)) THEN ! exact matching
11505 nuf=1
11506 ! WRITE(*,*) 'Cfiles'
11507 cycle
11508 END IF
11509
11510 keystx='closeandreopen' ! don't keep binary files open
11511 mat=matint(text(ia:ib),keystx,npat,ntext)
11512 IF(mat == max(npat,ntext)) THEN ! exact matching
11513 keepopen=0
11514 cycle
11515 END IF
11516
11517 ! file names
11518 ! check for file options (' -- ')
11519 ie=ib
11520 iopt=index(text(ia:ib),' -- ')
11521 IF (iopt > 0) ie=iopt-1
11522
11523 IF(nab == 0) cycle
11524 nu=nufile(text(ia:ie)) ! inquire on file existence
11525 IF(nu > 0) THEN ! existing file
11526 IF (nfiles == lenfileinfo) THEN ! increase length
11527 CALL mpalloc(temparray,rows,cols,'temp file info from steering')
11528 temparray=vecfileinfo
11529 CALL mpdealloc(vecfileinfo)
11530 lenfileinfo=lenfileinfo*2
11531 newcols=lenfileinfo
11532 CALL mpalloc(vecfileinfo,rows,newcols,'file info from steering')
11533 vecfileinfo(:,1:cols)=temparray(:,1:cols)
11534 CALL mpdealloc(temparray)
11535 cols=newcols
11536 ENDIF
11537 nfiles=nfiles+1 ! count number of files
11538 IF(nu == 1) nu=nuf !
11539 lenfilenames=lenfilenames+ie-ia+1 ! total length of file names
11540 vecfileinfo(1,nfiles)=nline ! line number
11541 vecfileinfo(2,nfiles)=nu ! cbinary =1, text =2, fbinary=3
11542 vecfileinfo(3,nfiles)=ia ! file name start
11543 vecfileinfo(4,nfiles)=ie ! file name end
11544 vecfileinfo(5,nfiles)=iopt ! option start
11545 vecfileinfo(6,nfiles)=ib ! option end
11546 ELSE
11547 ! WRITE(*,*) 'Open error for file ',TEXT(IA:IB)
11548 ! STOP
11549 END IF
11550 END DO
11551 rewind 10
11552 ! read again to fill dynamic arrays with file info
11553 length=nfiles
11554 CALL mpalloc(mfd,length,'file type')
11555 CALL mpalloc(nfd,length,'file line (in steering)')
11556 CALL mpalloc(lfd,length,'file name length')
11557 CALL mpalloc(ofd,length,'file option')
11558 length=lenfilenames
11559 CALL mpalloc(tfd,length,'file name')
11560 nline=0
11561 i=1
11562 ioff=0
11563 DO
11564 READ(10,102,iostat=ierrf) text ! read steering file
11565 IF (ierrf < 0) EXIT ! eof
11566 nline=nline+1
11567 IF (nline == vecfileinfo(1,i)) THEN
11568 nfd(i)=vecfileinfo(1,i)
11569 mfd(i)=vecfileinfo(2,i)
11570 ia=vecfileinfo(3,i)-1
11571 lfd(i)=vecfileinfo(4,i)-ia ! length file name
11572 DO k=1,lfd(i)
11573 tfd(ioff+k)=text(ia+k:ia+k)
11574 END DO
11575 ! tfd(i)=text(vecFileInfo(3,i):vecFileInfo(4,i)) ! file name
11576 ioff=ioff+lfd(i)
11577 ofd(i)=1.0 ! option for file
11578 IF (vecfileinfo(5,i) > 0) THEN
11579 CALL ratext(text(vecfileinfo(5,i)+4:vecfileinfo(6,i)),nums,dnum,mnum) ! translate text to DP numbers
11580 IF (nums > 0) ofd(i)=real(dnum(1),mps)
11581 END IF
11582 i=i+1
11583 IF (i > nfiles) EXIT
11584 ENDIF
11585 ENDDO
11586 CALL mpdealloc(vecfileinfo)
11587 rewind 10
11588 ! additional info for binary files
11589 length=nfiles; rows=2
11590 CALL mpalloc(ifd,length,'integrated record numbers (=offset)')
11591 CALL mpalloc(jfd,length,'number of accepted records')
11592 CALL mpalloc(kfd,rows,length,'number of records in file, file order')
11593 CALL mpalloc(dfd,length,'ndf sum')
11594 CALL mpalloc(xfd,length,'max. record size')
11595 CALL mpalloc(wfd,length,'file weight')
11596 CALL mpalloc(cfd,length,'chi2 sum')
11597 CALL mpalloc(sfd,rows,length,'start, end of file name in TFD')
11598 CALL mpalloc(yfd,length,'modification date')
11599 yfd=0
11600 !
11601 WRITE(*,*) '-------------------------'
11602 WRITE(*,*) ' '
11603
11604 ! print table of files ---------------------------------------------
11605
11606 IF (mprint > 1) THEN
11607 WRITE(*,*) 'Table of files:'
11608 WRITE(*,*) '---------------'
11609 END IF
11610 WRITE(8,*) ' '
11611 WRITE(8,*) 'Text and data files:'
11612 ioff=0
11613 DO i=1,nfiles
11614 DO k=1,lfd(i)
11615 fname(k:k)=tfd(ioff+k)
11616 END DO
11617 ! fname=tfd(i)(1:lfd(i))
11618 IF (mprint > 1) WRITE(*,103) i,bite(mfd(i)),fname(1:lfd(i))
11619 WRITE(8,103) i,bite(mfd(i)),fname(1:lfd(i))
11620 ioff=ioff+lfd(i)
11621 END DO
11622 IF (mprint > 1) THEN
11623 WRITE(*,*) '---------------'
11624 WRITE(*,*) ' '
11625 END IF
11626
11627 ! open the binary Fortran (data) files on unit 11, 12, ...
11628
11629 iosum=0
11630 nfilf=0
11631 nfilb=0
11632 nfilw=0
11633 ioff=0
11634 ifilb=0
11635 IF (keepopen < 1) ifilb=1
11636 DO i=1,nfiles
11637 IF(mfd(i) == 3) THEN
11638 nfilf=nfilf+1
11639 nfilb=nfilb+1
11640 ! next file name
11641 sfd(1,nfilb)=ioff
11642 sfd(2,nfilb)=lfd(i)
11643 CALL binopn(nfilb,ifilb,ios)
11644 IF(ios == 0) THEN
11645 wfd(nfilb)=ofd(i)
11646 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11647 ELSE ! failure
11648 iosum=iosum+1
11649 nfilf=nfilf-1
11650 nfilb=nfilb-1
11651 END IF
11652 END IF
11653 ioff=ioff+lfd(i)
11654 END DO
11655
11656 ! open the binary C files
11657
11658 nfilc=-1
11659 ioff=0
11660 DO i=1,nfiles ! Cfiles
11661 IF(mfd(i) == 1) THEN
11662#ifdef READ_C_FILES
11663 IF(nfilc < 0) THEN ! initialize
11664 CALL initc(max(nfiles,mthrdr)) ! uncommented by GF
11665 nfilc=0
11666 END IF
11667 nfilc=nfilc+1
11668 nfilb=nfilb+1
11669 ! next file name
11670 sfd(1,nfilb)=ioff
11671 sfd(2,nfilb)=lfd(i)
11672 CALL binopn(nfilb,ifilb,ios)
11673 IF(ios == 0) THEN
11674 wfd(nfilb)=ofd(i)
11675 IF (keepopen < 1) CALL bincls(nfilb,ifilb)
11676 ELSE ! failure
11677 iosum=iosum+1
11678 nfilc=nfilc-1
11679 nfilb=nfilb-1
11680 END IF
11681#else
11682 WRITE(*,*) 'Opening of C-files not supported.'
11683 ! GF add
11684 iosum=iosum+1
11685 ! GF add end
11686#endif
11687 END IF
11688 ioff=ioff+lfd(i)
11689 END DO
11690
11691 DO k=1,nfilb
11692 kfd(1,k)=1 ! reset (negated) record counters
11693 kfd(2,k)=k ! set file number
11694 ifd(k)=0 ! reset integrated record numbers
11695 xfd(k)=0 ! reset max record size
11696 END DO
11697
11698 IF(iosum /= 0) THEN
11699 CALL peend(15,'Aborted, open error(s) for binary files')
11700 stop 'FILETC: open error '
11701 END IF
11702 IF(nfilb == 0) THEN
11703 CALL peend(14,'Aborted, no binary files')
11704 stop 'FILETC: no binary files '
11705 END IF
11706 IF (keepopen > 0) THEN
11707 WRITE(*,*) nfilb,' binary files opened' ! corrected by GF
11708 ELSE
11709 WRITE(*,*) nfilb,' binary files opened and closed' ! corrected by GF
11710 END IF
11711101 FORMAT(i3,2x,a)
11712102 FORMAT(a)
11713103 FORMAT(i3,2x,a14,3x,a)
11714 ! CALL mend
11715 RETURN
11716END SUBROUTINE filetc
11717
11768
11769SUBROUTINE filetx ! ---------------------------------------------------
11770 USE mpmod
11771
11772 IMPLICIT NONE
11773 INTEGER(mpi) :: i
11774 INTEGER(mpi) :: ia
11775 INTEGER(mpi) :: ib
11776 INTEGER(mpi) :: ierrf
11777 INTEGER(mpi) :: ioff
11778 INTEGER(mpi) :: ios
11779 INTEGER(mpi) :: iosum
11780 INTEGER(mpi) :: k
11781 INTEGER(mpi) :: mat
11782 INTEGER(mpi) :: nab
11783 INTEGER(mpi) :: nfiln
11784 INTEGER(mpi) :: nline
11785 INTEGER(mpi) :: nlinmx
11786 INTEGER(mpi) :: npat
11787 INTEGER(mpi) :: ntext
11788 INTEGER(mpi) :: matint
11789
11790 ! CALL MSTART('FILETX')
11791
11792 CHARACTER (LEN=1024) :: text
11793 CHARACTER (LEN=1024) :: fname
11794
11795 WRITE(*,*) ' '
11796 WRITE(*,*) 'Processing text files ...'
11797 WRITE(*,*) ' '
11798
11799 iosum=0
11800 ioff=0
11801 DO i=0,nfiles
11802 IF(i == 0) THEN
11803 WRITE(*,*) 'File ',filnam(1:nfnam)
11804 nlinmx=100
11805 ELSE
11806 nlinmx=10
11807 ia=ioff
11808 ioff=ioff+lfd(i)
11809 IF(mfd(i) /= 2) cycle ! exclude binary files
11810 DO k=1,lfd(i)
11811 fname(k:k)=tfd(ia+k)
11812 END DO
11813 WRITE(*,*) 'File ',fname(1:lfd(i))
11814 IF (mprint > 1) WRITE(*,*) ' '
11815 OPEN(10,file=fname(1:lfd(i)),iostat=ios,form='FORMATTED')
11816 IF(ios /= 0) THEN
11817 WRITE(*,*) 'Open error for file ',fname(1:lfd(i))
11818 iosum=iosum+1
11819 cycle
11820 END IF
11821 END IF
11822
11823 nline=0
11824 nfiln=1
11825 ! read text file
11826 DO
11827 READ(10,102,iostat=ierrf) text
11828 IF (ierrf < 0) THEN
11829 text=' '
11830 CALL intext(text,nline)
11831 WRITE(*,*) ' end-of-file after',nline,' text lines'
11832 EXIT ! eof
11833 ENDIF
11834 nline=nline+1
11835 IF(nline <= nlinmx.AND.mprint > 1) THEN ! print first 10 lines of every text fiLE
11836 CALL rltext(text,ia,ib,nab)
11837 nab=max(1,nab)
11838 WRITE(*,101) nline,text(1:nab)
11839 IF(nline == nlinmx) WRITE(*,*) ' ...'
11840 END IF
11841
11842 CALL rltext(text,ia,ib,nab) ! test content 'end'
11843 IF(ib == ia+2) THEN
11844 mat=matint(text(ia:ib),'end',npat,ntext)
11845 IF(mat == max(npat,ntext)) THEN ! exact matching
11846 text=' '
11847 CALL intext(text,nline)
11848 WRITE(*,*) ' end-statement after',nline,' text lines'
11849 EXIT
11850 END IF
11851 END IF
11852
11853 IF(i == 0) THEN ! first text file - exclude lines with file names
11854 IF(nfiln <= nfiles) THEN
11855 IF(nline == nfd(nfiln)) THEN
11856 nfiln=nfiln+1
11857 text=' '
11858 ! WRITE(*,*) 'line is excluded ',TEXT(1:10)
11859 END IF
11860 END IF
11861 END IF
11862 ! WRITE(*,*) TEXT(1:40),' < interprete text'
11863 CALL intext(text,nline) ! interprete text
11864 END DO
11865 WRITE(*,*) ' '
11866 rewind 10
11867 CLOSE(unit=10)
11868 END DO
11869
11870 IF(iosum /= 0) THEN
11871 CALL peend(16,'Aborted, open error(s) for text files')
11872 stop 'FILETX: open error(s) in text files '
11873 END IF
11874
11875 WRITE(*,*) '... end of text file processing.'
11876 WRITE(*,*) ' '
11877
11878 IF(lunkno /= 0) THEN
11879 WRITE(*,*) ' '
11880 WRITE(*,*) lunkno,' unknown keywords in steering files, ', &
11881 'or file non-existing,'
11882 WRITE(*,*) ' see above!'
11883 WRITE(*,*) '------------> stop'
11884 WRITE(*,*) ' '
11885 CALL peend(13,'Aborted, unknown keywords in steering file')
11886 stop
11887 END IF
11888
11889 ! check methods
11890
11891 IF(metsol == 0) THEN ! if undefined
11892 IF(matsto == 0) THEN ! if unpacked symmetric
11893 metsol=8 ! LAPACK
11894 ELSE IF(matsto == 1) THEN ! if full symmetric
11895 metsol=4 ! MINRES
11896 ELSE IF(matsto == 2) THEN ! if sparse
11897 metsol=4 ! MINRES
11898 END IF
11899 ELSE IF(metsol == 1) THEN ! if inversion
11900 matsto=1
11901 ELSE IF(metsol == 2) THEN ! if diagonalization
11902 matsto=1
11903 ELSE IF(metsol == 3) THEN ! if decomposition
11904 matsto=1
11905 ELSE IF(metsol == 4) THEN ! if MINRES
11906 ! MATSTO=2 or 1
11907 ELSE IF(metsol == 5) THEN ! if MINRES-QLP
11908 ! MATSTO=2 or 1
11909 ELSE IF(metsol == 6) THEN ! if GMRES
11910 ! MATSTO=2 or 1
11911#ifdef LAPACK64
11912 ELSE IF(metsol == 7) THEN ! if LAPACK
11913 matsto=1
11914 ELSE IF(metsol == 8) THEN ! if LAPACK
11915 matsto=0
11916#ifdef PARDISO
11917 ELSE IF(metsol == 9) THEN ! if Intel oneMKL PARDISO
11918 matsto=3
11919#endif
11920#endif
11921 ELSE
11922 WRITE(*,*) 'MINRES forced with sparse matrix!'
11923 WRITE(*,*) ' '
11924 WRITE(*,*) 'MINRES forced with sparse matrix!'
11925 WRITE(*,*) ' '
11926 WRITE(*,*) 'MINRES forced with sparse matrix!'
11927 metsol=4 ! forced
11928 matsto=2 ! forced
11929 END IF
11930 IF(matsto > 4) THEN
11931 WRITE(*,*) 'MINRES forced with sparse matrix!'
11932 WRITE(*,*) ' '
11933 WRITE(*,*) 'MINRES forced with sparse matrix!'
11934 WRITE(*,*) ' '
11935 WRITE(*,*) 'MINRES forced with sparse matrix!'
11936 metsol=4 ! forced
11937 matsto=2 ! forced
11938 END IF
11939
11940 ! print information about methods and matrix storage modes
11941
11942 WRITE(*,*) ' '
11943 WRITE(*,*) 'Solution method and matrix-storage mode:'
11944 IF(metsol == 1) THEN
11945 WRITE(*,*) ' METSOL = 1: matrix inversion'
11946 ELSE IF(metsol == 2) THEN
11947 WRITE(*,*) ' METSOL = 2: diagonalization'
11948 ELSE IF(metsol == 3) THEN
11949 WRITE(*,*) ' METSOL = 3: decomposition'
11950 ELSE IF(metsol == 4) THEN
11951 WRITE(*,*) ' METSOL = 4: MINRES'
11952 ELSE IF(metsol == 5) THEN
11953 WRITE(*,*) ' METSOL = 5: MINRES-QLP'
11954 ELSE IF(metsol == 6) THEN
11955 WRITE(*,*) ' METSOL = 6: GMRES (-> MINRES)'
11956#ifdef LAPACK64
11957 ELSE IF(metsol == 7) THEN
11958 WRITE(*,*) ' METSOL = 7: LAPACK factorization'
11959 ELSE IF(metsol == 8) THEN
11960 WRITE(*,*) ' METSOL = 8: LAPACK factorization'
11961#ifdef PARDISO
11962 ELSE IF(metsol == 9) THEN
11963 WRITE(*,*) ' METSOL = 9: Intel oneMKL PARDISO'
11964#endif
11965#endif
11966 END IF
11967
11968 WRITE(*,*) ' with',mitera,' iterations'
11969
11970 IF(matsto == 0) THEN
11971 WRITE(*,*) ' MATSTO = 0: unpacked symmetric matrix, ', 'n*n elements'
11972 ELSEIF(matsto == 1) THEN
11973 WRITE(*,*) ' MATSTO = 1: full symmetric matrix, ', '(n*n+n)/2 elements'
11974 ELSE IF(matsto == 2) THEN
11975 WRITE(*,*) ' MATSTO = 2: sparse matrix (custom)'
11976 ELSE IF(matsto == 3) THEN
11977 IF (mpdbsz == 0) THEN
11978 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, CSR3)'
11979 ELSE
11980 WRITE(*,*) ' MATSTO = 3: sparse matrix (upper triangle, BSR3)'
11981 END IF
11982 END IF
11983 IF(mbandw /= 0.AND.(metsol >= 4.AND. metsol <7)) THEN ! band matrix as MINRES preconditioner
11984 WRITE(*,*) ' and band matrix, width',mbandw
11985 END IF
11986
11987 IF(chicut /= 0.0) THEN
11988 WRITE(*,*) 'Chi square cut equiv 3 st.dev applied ...'
11989 WRITE(*,*) ' in first iteration with factor',chicut
11990 WRITE(*,*) ' in second iteration with factor',chirem
11991 WRITE(*,*) ' (reduced by sqrt in next iterations)'
11992 END IF
11993
11994 IF(lhuber /= 0) THEN
11995 WRITE(*,*) ' Down-weighting of outliers in', lhuber,' iterations'
11996 WRITE(*,*) ' Cut on downweight fraction',dwcut
11997 END IF
11998
11999 WRITE(*,*) 'Iterations (solutions) with line search:'
12000 IF(lsearch > 2) THEN
12001 WRITE(*,*) ' All'
12002 ELSEIF (lsearch == 1) THEN
12003 WRITE(*,*) ' Last'
12004 ELSEIF (lsearch < 1) THEN
12005 WRITE(*,*) ' None'
12006 ELSE
12007 IF (chicut /= 0.0) THEN
12008 WRITE(*,*) ' All with Chi square cut scaling factor <= 1.'
12009 ELSE
12010 WRITE(*,*) ' All'
12011 ENDIF
12012 ENDIF
12013
12014 IF(nummeasurements>0) THEN
12015 WRITE(*,*)
12016 WRITE(*,*) ' Number of external measurements ', nummeasurements
12017 ENDIF
12018
12019 CALL mend
12020
12021101 FORMAT(i3,2x,a)
12022102 FORMAT(a)
12023END SUBROUTINE filetx
12024
12034
12035INTEGER(mpi) FUNCTION nufile(fname)
12036 USE mpdef
12037
12038 IMPLICIT NONE
12039 INTEGER(mpi) :: ios
12040 INTEGER(mpi) :: l1
12041 INTEGER(mpi) :: ll
12042 INTEGER(mpi) :: nm
12043 INTEGER(mpi) :: npat
12044 INTEGER(mpi) :: ntext
12045 INTEGER(mpi) :: nuprae
12046 INTEGER(mpi) :: matint
12047
12048 CHARACTER (LEN=*), INTENT(INOUT) :: fname
12049 LOGICAL :: ex
12050 SAVE
12051 ! ...
12052 nufile=0
12053 nuprae=0
12054 IF(len(fname) > 5) THEN
12055 IF(fname(1:5) == 'rfio:') nuprae=1
12056 IF(fname(1:5) == 'dcap:') nuprae=2
12057 IF(fname(1:5) == 'root:') nuprae=3
12058 END IF
12059 IF(nuprae == 0) THEN
12060 INQUIRE(file=fname,iostat=ios,exist=ex)
12061 IF(ios /= 0) nufile=-abs(ios)
12062 IF(ios /= 0) RETURN
12063 ELSE IF(nuprae == 1) THEN ! rfio:
12064 ll=len(fname)
12065 fname=fname(6:ll)
12066 ex=.true.
12067 nufile=1
12068 RETURN
12069 ELSE
12070 ex=.true. ! assume file existence
12071 END IF
12072 IF(ex) THEN
12073 nufile=1 ! binary
12074 ll=len(fname)
12075 l1=max(1,ll-3)
12076 nm=matint('xt',fname(l1:ll),npat,ntext)
12077 IF(nm == 2) nufile=2 ! text
12078 IF(nm < 2) THEN
12079 nm=matint('tx',fname(l1:ll),npat,ntext)
12080 IF(nm == 2) nufile=2 ! text
12081 END IF
12082 END IF
12083END FUNCTION nufile
12084
12092SUBROUTINE intext(text,nline)
12093 USE mpmod
12094 USE mptext
12095
12096 IMPLICIT NONE
12097 INTEGER(mpi) :: i
12098 INTEGER(mpi) :: ia
12099 INTEGER(mpi) :: ib
12100 INTEGER(mpi) :: ier
12101 INTEGER(mpi) :: iomp
12102 INTEGER(mpi) :: j
12103 INTEGER(mpi) :: k
12104 INTEGER(mpi) :: kkey
12105 INTEGER(mpi) :: label
12106 INTEGER(mpi) :: lkey
12107 INTEGER(mpi) :: mat
12108 INTEGER(mpi) :: miter
12109 INTEGER(mpi) :: nab
12110 INTEGER(mpi) :: nkey
12111 INTEGER(mpi) :: nkeys
12112 INTEGER(mpi) :: nl
12113 INTEGER(mpi) :: nmeth
12114 INTEGER(mpi) :: npat
12115 INTEGER(mpi) :: ntext
12116 INTEGER(mpi) :: nums
12117 INTEGER(mpi) :: matint
12118
12119 CHARACTER (LEN=*), INTENT(IN) :: text
12120 INTEGER(mpi), INTENT(IN) :: nline
12121
12122#ifdef LAPACK64
12123#ifdef PARDISO
12124 parameter(nkeys=7,nmeth=10)
12125#else
12126 parameter(nkeys=6,nmeth=9)
12127#endif
12128#else
12129 parameter(nkeys=6,nmeth=7)
12130#endif
12131 CHARACTER (LEN=16) :: methxt(nmeth)
12132 CHARACTER (LEN=16) :: keylst(nkeys)
12133 CHARACTER (LEN=32) :: keywrd
12134 CHARACTER (LEN=32) :: keystx
12135 CHARACTER (LEN=itemCLen) :: ctext
12136 INTEGER(mpi), PARAMETER :: mnum=100
12137 REAL(mpd) :: dnum(mnum)
12138#ifdef LAPACK64
12139#ifdef PARDISO
12140 INTEGER(mpi) :: ipvs ! ... integer value
12141#endif
12142#endif
12143 INTEGER(mpi) :: lpvs ! ... integer label
12144 REAL(mpd) :: plvs ! ... float value
12145
12146 INTERFACE
12147 SUBROUTINE additem(length,list,label,value)
12148 USE mpmod
12149 INTEGER(mpi), INTENT(IN OUT) :: length
12150 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12151 INTEGER(mpi), INTENT(IN) :: label
12152 REAL(mpd), INTENT(IN) :: value
12153 END SUBROUTINE additem
12154 SUBROUTINE additemc(length,list,label,text)
12155 USE mpmod
12156 INTEGER(mpi), INTENT(IN OUT) :: length
12157 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12158 INTEGER(mpi), INTENT(IN) :: label
12159 CHARACTER(LEN = itemCLen), INTENT(IN) :: text
12160 END SUBROUTINE additemc
12161 SUBROUTINE additemi(length,list,label,ivalue)
12162 USE mpmod
12163 INTEGER(mpi), INTENT(IN OUT) :: length
12164 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12165 INTEGER(mpi), INTENT(IN) :: label
12166 INTEGER(mpi), INTENT(IN) :: ivalue
12167 END SUBROUTINE additemi
12168 END INTERFACE
12169
12170 SAVE
12171#ifdef LAPACK64
12172#ifdef PARDISO
12173 DATA keylst/'unknown','parameter','constraint','measurement','method','comment','pardiso'/
12174 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12175 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK', &
12176 'sparsePARDISO'/
12177#else
12178 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
12179 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12180 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition', 'fullLAPACK', 'unpackedLAPACK'/
12181#endif
12182#else
12183 DATA keylst/'unknown','parameter','constraint','measurement','method','comment'/
12184 DATA methxt/'diagonalization','inversion','fullMINRES', 'sparseMINRES', &
12185 'fullMINRES-QLP', 'sparseMINRES-QLP', 'decomposition'/
12186#endif
12187 DATA lkey/-1/ ! last keyword
12188
12189 ! ...
12190 nkey=-1 ! new keyword
12191 CALL rltext(text,ia,ib,nab) ! return indices for non-blank area
12192 IF(nab == 0) GOTO 10
12193 CALL ratext(text(1:nab),nums,dnum,mnum) ! translate text to DP numbers
12194
12195 IF(nums /= 0) nkey=0
12196 IF(keyb /= 0) THEN
12197 keywrd=text(keya:keyb) ! text is TEXT(KEYA)...TEXT(KEYB)
12198 ! WRITE(*,*) 'Keyword is ',KEYWRD
12199
12200 ! compare keywords
12201
12202 DO nkey=2,nkeys ! loop over all pede keywords
12203 keystx=keylst(nkey) ! copy NKEY.th pede keyword
12204 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12205 IF(100*mat >= 80*max(npat,ntext)) GO TO 10 ! 80% (symmetric) matching
12206 END DO
12207
12208 ! more comparisons
12209
12210 keystx='print'
12211 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12212 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12213 mprint=1
12214 IF(nums > 0) mprint=nint(dnum(1),mpi)
12215 RETURN
12216 END IF
12217
12218 keystx='debug'
12219 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12220 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12221 mdebug=3
12222 ! GF IF(NUMS.GT.0) MPRINT=DNUM(1)
12223 IF(nums > 0) mdebug=nint(dnum(1),mpi)
12224 IF(nums > 1) mdebg2=nint(dnum(2),mpi)
12225 RETURN
12226 END IF
12227
12228 keystx='entries'
12229 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12230 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12231 IF(nums > 0 .AND. dnum(1) > 0.5) mreqenf=nint(dnum(1),mpi)
12232 IF(nums > 1 .AND. dnum(2) > 0.5) mreqena=nint(dnum(2),mpi)
12233 IF(nums > 2 .AND. dnum(3) > 0.5) iteren=nint(dnum(1)*dnum(3),mpi)
12234 RETURN
12235 END IF
12236
12237 keystx='printrecord'
12238 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12239 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12240 IF(nums > 0) nrecpr=nint(dnum(1),mpi)
12241 IF(nums > 1) nrecp2=nint(dnum(2),mpi)
12242 RETURN
12243 END IF
12244
12245 keystx='maxrecord'
12246 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12247 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12248 IF (nums > 0.AND.dnum(1) > 0.) mxrec=nint(dnum(1),mpi)
12249 RETURN
12250 END IF
12251
12252 keystx='cache'
12253 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12254 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12255 IF (nums > 0.AND.dnum(1) >= 0.) ncache=nint(dnum(1),mpi) ! cache size, <0 keeps default
12256 IF (nums == 2.AND.dnum(2) > 0..AND.dnum(2) <= 1.0) & ! read cache fill level
12257 fcache(1)=real(dnum(2),mps)
12258 IF (nums >= 4) THEN ! explicit cache splitting
12259 DO k=1,3
12260 fcache(k)=real(dnum(k+1),mps)
12261 END DO
12262 END IF
12263 RETURN
12264 END IF
12265
12266 keystx='chisqcut'
12267 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12268 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12269 IF(nums == 0) THEN ! always 3-sigma cut
12270 chicut=1.0
12271 chirem=1.0
12272 ELSE
12273 chicut=real(dnum(1),mps)
12274 IF(chicut < 1.0) chicut=-1.0
12275 IF(nums == 1) THEN
12276 chirem=1.0 ! 3-sigma cut, if not specified
12277 ELSE
12278 chirem=real(dnum(2),mps)
12279 IF(chirem < 1.0) chirem=1.0
12280 IF(chicut >= 1.0) chirem=min(chirem,chicut)
12281 END IF
12282 END IF
12283 RETURN
12284 END IF
12285
12286 ! GF added:
12287 keystx='hugecut'
12288 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12289 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12290 IF(nums > 0) chhuge=real(dnum(1),mps)
12291 IF(chhuge < 1.0) chhuge=1.0 ! at least (!!) 3-sigma
12292 RETURN
12293 END IF
12294 ! GF added end
12295
12296 keystx='linesearch'
12297 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12298 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12299 IF(nums > 0) lsearch=nint(dnum(1),mpi)
12300 RETURN
12301 END IF
12302
12303 keystx='localfit'
12304 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12305 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12306 IF(nums > 0) lfitnp=nint(dnum(1),mpi)
12307 IF(nums > 1) lfitbb=nint(dnum(2),mpi)
12308 RETURN
12309 END IF
12310
12311 keystx='regularization'
12312 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12313 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12314 nregul=1
12315 regula=real(dnum(1),mps)
12316 IF(nums >= 2) regpre=real(dnum(2),mps)
12317 RETURN
12318 END IF
12319
12320 keystx='regularisation'
12321 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12322 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12323 nregul=1
12324 regula=real(dnum(1),mps)
12325 IF(nums >= 2) regpre=real(dnum(2),mps)
12326 RETURN
12327 END IF
12328
12329 keystx='presigma'
12330 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12331 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12332 regpre=real(dnum(1),mps)
12333 RETURN
12334 END IF
12335
12336 keystx='matiter'
12337 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12338 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12339 matrit=nint(dnum(1),mpi)
12340 RETURN
12341 END IF
12342
12343 keystx='matmoni'
12344 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12345 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12346 matmon=-1
12347 IF (nums > 0.AND.dnum(1) > 0.) matmon=nint(dnum(1),mpi)
12348 RETURN
12349 END IF
12350
12351 keystx='bandwidth'
12352 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12353 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12354 IF(nums > 0) mbandw=nint(dnum(1),mpi)
12355 IF(mbandw < 0) mbandw=-1
12356 IF(nums > 1) lprecm=nint(dnum(2),mpi)
12357 RETURN
12358 END IF
12359
12360 ! KEYSTX='outlierrejection'
12361 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12362 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12363 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12364 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12365 ! CHDFRJ=DNUM(1)
12366 ! IF(CHDFRJ.LT.3.0) CHDFRJ=100.0
12367 ! RETURN
12368 ! END IF
12369
12370 ! KEYSTX='outliersuppression'
12371 ! MAT=MATINT(TEXT(KEYA:KEYB),KEYSTX,NPAT,NTEXT) ! comparison
12372 ! WRITE(*,*) KEYSTX,MAT,(NTEXT+NTEXT)/3
12373 ! IF(MAT.GE.(NTEXT+NTEXT+NTEXT-2)/3) THEN
12374 ! IF(MAT.GE.(NPAT-NPAT/5)) THEN
12375 ! LHUBER=DNUM(1)
12376 ! IF(LHUBER.LE.2) LHUBER=2 ! at least 2 Huber iterations
12377 ! RETURN
12378 ! END IF
12379
12380 keystx='outlierdownweighting'
12381 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12382 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12383 lhuber=nint(dnum(1),mpi)
12384 IF(lhuber > 0.AND.lhuber <= 2) lhuber=2 ! at least 2 Huber iterations (if any)
12385 RETURN
12386 END IF
12387
12388 keystx='dwfractioncut'
12389 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12390 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12391 dwcut=real(dnum(1),mps)
12392 IF(dwcut > 0.5) dwcut=0.5
12393 RETURN
12394 END IF
12395
12396 keystx='maxlocalcond'
12397 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12398 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12399 IF (nums > 0.AND.dnum(1) > 0.0) cndlmx=real(dnum(1),mps)
12400 RETURN
12401 END IF
12402
12403 keystx='pullrange'
12404 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12405 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12406 prange=abs(real(dnum(1),mps))
12407 RETURN
12408 END IF
12409
12410 keystx='subito'
12411 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12412 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12413 isubit=1
12414 RETURN
12415 END IF
12416
12417 keystx='force'
12418 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12419 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12420 iforce=1
12421 RETURN
12422 END IF
12423
12424 keystx='memorydebug'
12425 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12426 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12427 memdbg=1
12428 IF (nums > 0.AND.dnum(1) > 0.0) memdbg=nint(dnum(1),mpi)
12429 RETURN
12430 END IF
12431
12432 keystx='globalcorr'
12433 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12434 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12435 igcorr=1
12436 RETURN
12437 END IF
12438
12439 keystx='printcounts'
12440 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12441 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12442 ipcntr=1
12443 IF (nums > 0) ipcntr=nint(dnum(1),mpi)
12444 RETURN
12445 END IF
12446
12447 keystx='weightedcons'
12448 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12449 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12450 iwcons=1
12451 IF (nums > 0) iwcons=nint(dnum(1),mpi)
12452 RETURN
12453 END IF
12454
12455 keystx='skipemptycons'
12456 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12457 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12458 iskpec=1
12459 RETURN
12460 END IF
12461
12462 keystx='resolveredundancycons'
12463 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12464 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12465 irslvrc=1
12466 RETURN
12467 END IF
12468
12469 keystx='withelimination'
12470 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12471 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12472 icelim=1
12473 RETURN
12474 END IF
12475
12476 keystx='postprocessing'
12477 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12478 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12479 lenpostproc=ib-keyb-1
12480 cpostproc(1:lenpostproc)=text(keyb+2:ib)
12481 RETURN
12482 END IF
12483
12484#ifdef LAPACK64
12485 keystx='withLAPACKelimination'
12486 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12487 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12488 icelim=2
12489 RETURN
12490 END IF
12491#endif
12492
12493 keystx='withmultipliers'
12494 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12495 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12496 icelim=0
12497 RETURN
12498 END IF
12499
12500 keystx='checkinput'
12501 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12502 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12503 icheck=1
12504 IF (nums > 0) icheck=nint(dnum(1),mpi)
12505 RETURN
12506 END IF
12507
12508 keystx='checkparametergroups'
12509 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12510 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12511 ichkpg=1
12512 RETURN
12513 END IF
12514
12515 keystx='monitorresiduals'
12516 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12517 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12518 imonit=3
12519 IF (nums > 0) imonit=nint(dnum(1),mpi)
12520 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12521 RETURN
12522 END IF
12523
12524 keystx='monitorpulls'
12525 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12526 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12527 imonit=3
12528 imonmd=1
12529 IF (nums > 0) imonit=nint(dnum(1),mpi)
12530 IF (nums > 1) measbins=max(measbins,nint(dnum(2),mpi))
12531 RETURN
12532 END IF
12533
12534 keystx='monitorprogress'
12535 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12536 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12537 monpg1=1
12538 monpg2=1024
12539 IF (nums > 0) monpg1=max(1,nint(dnum(1),mpi))
12540 IF (nums > 1) monpg2=max(1,nint(dnum(2),mpi))
12541 RETURN
12542 END IF
12543
12544 keystx='scaleerrors'
12545 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12546 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12547 iscerr=1
12548 IF (nums > 0) dscerr(1:2)=dnum(1)
12549 IF (nums > 1) dscerr(2)=dnum(2)
12550 RETURN
12551 END IF
12552
12553 keystx='iterateentries'
12554 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12555 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12556 iteren=huge(iteren)
12557 IF (nums > 0) iteren=nint(dnum(1),mpi)
12558 RETURN
12559 END IF
12560
12561 keystx='threads'
12562 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12563 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12564 iomp=0
12565 !$ IOMP=1
12566 !$ IF (IOMP.GT.0) THEN
12567 !$ IF (NUMS.GE.1.AND.DNUM(1).GT.0.) MTHRD =NINT(dnum(1),mpi)
12568 !$ MTHRDR=MTHRD
12569 !$ IF (NUMS.GE.2.AND.DNUM(2).GT.0.) MTHRDR=NINT(dnum(2),mpi)
12570 !$ ELSE
12571 WRITE(*,*) 'WARNING: multithreading not available'
12572 !$ ENDIF
12573 RETURN
12574 END IF
12575
12576 keystx='compress'
12577 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12578 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12579 WRITE(*,*) 'WARNING: keyword COMPRESS is obsolete (compression is default)'
12580 RETURN
12581 END IF
12582
12583 ! still experimental
12584 !keystx='extendedStorage'
12585 !mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12586 !IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12587 ! mextnd=1
12588 ! RETURN
12589 !END IF
12590
12591 keystx='countrecords'
12592 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12593 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12594 mcount=1
12595 RETURN
12596 END IF
12597
12598 keystx='errlabels'
12599 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12600 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12601 nl=min(nums,100-mnrsel)
12602 DO k=1,nl
12603 lbmnrs(mnrsel+k)=nint(dnum(k),mpi)
12604 END DO
12605 mnrsel=mnrsel+nl
12606 RETURN
12607 END IF
12608
12609 keystx='pairentries'
12610 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12611 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12612 ! This option could be implemented to get rid of parameter pairs
12613 ! that have very few entries - to save matrix memory size.
12614 IF (nums > 0.AND.dnum(1) > 0.0) THEN
12615 mreqpe=nint(dnum(1),mpi)
12616 IF (nums >= 2.AND.dnum(2) >= dnum(1)) mhispe=nint(dnum(2),mpi)
12617 IF (nums >= 3.AND.dnum(3) >= dnum(1)) msngpe=nint(dnum(3),mpi)
12618 END IF
12619 RETURN
12620 END IF
12621
12622 keystx='wolfe'
12623 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12624 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12625 wolfc1=real(dnum(1),mps)
12626 wolfc2=real(dnum(2),mps)
12627 RETURN
12628 END IF
12629
12630 ! GF added:
12631 ! convergence tolerance for minres:
12632 keystx='mrestol'
12633 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12634 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12635 IF(nums > 0) THEN
12636 IF (dnum(1) < 1.0e-10_mpd.OR.dnum(1) > 1.0e-04_mpd) THEN
12637 WRITE(*,*) 'ERROR: need 1.0D-10 <= MRESTL ', &
12638 '<= 1.0D-04, but get ', dnum(1)
12639 ELSE
12640 mrestl=dnum(1)
12641 END IF
12642 END IF
12643 RETURN
12644 END IF
12645 ! GF added end
12646
12647 keystx='mrestranscond'
12648 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12649 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12650 IF(nums > 0) THEN
12651 mrtcnd = dnum(1)
12652 END IF
12653 RETURN
12654 END IF
12655
12656 keystx='mresmode'
12657 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12658 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12659 IF(nums > 0) THEN
12660 mrmode = int(dnum(1),mpi)
12661 END IF
12662 RETURN
12663 END IF
12664
12665 keystx='nofeasiblestart'
12666 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12667 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12668 nofeas=1 ! do not make parameters feasible at start
12669 RETURN
12670 END IF
12671
12672 keystx='histprint'
12673 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12674 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12675 nhistp=1 ! print histograms
12676 RETURN
12677 END IF
12678
12679 keystx='readerroraseof' ! treat (C) read errors as eof
12680 mat=matint(text(ia:ib),keystx,npat,ntext)
12681 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12682 ireeof=1
12683 RETURN
12684 END IF
12685
12686#ifdef LAPACK64
12687 keystx='LAPACKwitherrors' ! calculate parameter errors with LAPACK
12688 mat=matint(text(ia:ib),keystx,npat,ntext)
12689 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12690 ilperr=1
12691 RETURN
12692 END IF
12693#ifdef PARDISO
12694 keystx='debugPARDISO' ! enable debug for Intel oneMKL PARDISO
12695 mat=matint(text(ia:ib),keystx,npat,ntext)
12696 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12697 ipddbg=1
12698 RETURN
12699 END IF
12700
12701 keystx='blocksizePARDISO' ! use BSR3 for Intel oneMKL PARDISO, list of (increasing) block sizes to be tried
12702 mat=matint(text(keya:keyb),keystx,npat,ntext) ! comparison
12703 IF(100*mat >= 80*max(npat,ntext).AND.mnrsel < 100) THEN ! 80% (symmetric) matching
12704 nl=min(nums,10-mpdbsz)
12705 DO k=1,nl
12706 IF (nint(dnum(k),mpi) > 0) THEN
12707 IF (mpdbsz == 0) THEN
12708 mpdbsz=mpdbsz+1
12709 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12710 ELSE IF (nint(dnum(k),mpi) > ipdbsz(mpdbsz)) THEN
12711 mpdbsz=mpdbsz+1
12712 ipdbsz(mpdbsz)=nint(dnum(k),mpi)
12713 END IF
12714 END IF
12715 END DO
12716 RETURN
12717 END IF
12718#endif
12719#endif
12720 keystx='fortranfiles'
12721 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12722 IF(mat == max(npat,ntext)) RETURN
12723
12724 keystx='Cfiles'
12725 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12726 IF(mat == max(npat,ntext)) RETURN
12727
12728 keystx='closeandreopen'
12729 mat=matint(text(ia:ib),keystx,npat,ntext) ! comparison
12730 IF(mat == max(npat,ntext)) RETURN
12731
12732 keystx=keylst(1)
12733 nkey=1 ! unknown keyword
12734 IF(nums /= 0) nkey=0
12735
12736 WRITE(*,*) ' '
12737 WRITE(*,*) '**************************************************'
12738 WRITE(*,*) ' '
12739 WRITE(*,*) 'Unknown keyword(s): ',text(1:min(nab,50))
12740 WRITE(*,*) ' '
12741 WRITE(*,*) '**************************************************'
12742 WRITE(*,*) ' '
12743 lunkno=lunkno+1
12744
12745 END IF
12746 ! result: NKEY = -1 blank
12747 ! NKEY = 0 numerical data, no text keyword or unknown
12748 ! NKEY > 0 keyword NKEY from list, keyword = KEYSTX
12749
12750
12751 ! content/lastcontent
12752 ! -------------------
12753 ! blank -1
12754 ! data 0
12755 ! keyword
12756 ! unknown 1
12757 ! parameter 2
12758 ! constraint 3
12759 ! measurement 4
12760 ! method 5
12761
12762
1276310 IF(nkey > 0) THEN ! new keyword
12764 lkey=nkey
12765 IF(lkey == 2) THEN ! parameter
12766 IF(nums == 3) THEN
12767 lpvs=nint(dnum(1),mpi) ! label
12768 IF(lpvs /= 0) THEN
12769 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12770 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12771 ELSE
12772 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12773 END IF
12774 ELSE IF(nums /= 0) THEN
12775 kkey=1 ! switch to "unknown" ?
12776 WRITE(*,*) 'Wrong text in line',nline
12777 WRITE(*,*) 'Status: new parameter'
12778 WRITE(*,*) '> ',text(1:nab)
12779 END IF
12780 ELSE IF(lkey == 3) THEN ! constraint
12781 ! WRITE(*,*) 'Keyword is constraint!',NUMS,' numerical data'
12782 IF(nums >= 1.AND.nums <= 2) THEN ! start constraint
12783 lpvs=-nline ! r = r.h.s. value
12784 CALL additem(lenconstraints,listconstraints,lpvs,dnum(1))
12785 lpvs=-1 ! constraint
12786 IF(iwcons > 0) lpvs=-2 ! weighted constraint
12787 plvs=0.0
12788 IF(nums == 2) plvs=dnum(2) ! sigma
12789 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12790 ELSE
12791 kkey=1 ! switch to "unknown"
12792 WRITE(*,*) 'Wrong text in line',nline
12793 WRITE(*,*) 'Status: new keyword constraint'
12794 WRITE(*,*) '> ',text(1:nab)
12795 END IF
12796 ELSE IF(lkey == 4) THEN ! measurement
12797 IF(nums == 2) THEN ! start measurement
12798 nummeasurements=nummeasurements+1
12799 lpvs=-nline ! r = r.h.s. value
12800 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(1))
12801 lpvs=-1 ! sigma
12802 CALL additem(lenmeasurements,listmeasurements,lpvs,dnum(2))
12803 ELSE
12804 kkey=1 ! switch to "unknown"
12805 WRITE(*,*) 'Wrong text in line',nline
12806 WRITE(*,*) 'Status: new keyword measurement'
12807 WRITE(*,*) '> ',text(1:nab)
12808 END IF
12809 ELSE IF(lkey == 5.AND.keyb < keyc) THEN ! method with text argument
12810 miter=mitera
12811 IF(nums >= 1) miter=nint(dnum(1),mpi)
12812 IF(miter >= 1) mitera=miter
12813 dflim=real(dnum(2),mps)
12814 lkey=0
12815 DO i=1,nmeth
12816 keystx=methxt(i)
12817 mat=matint(text(keyb+1:keyc),keystx,npat,ntext) ! comparison
12818 IF(100*mat >= 80*max(npat,ntext)) THEN ! 80% (symmetric) matching
12819 IF(i == 1) THEN ! diagonalization
12820 metsol=2
12821 matsto=1
12822 ELSE IF(i == 2) THEN ! inversion
12823 metsol=1
12824 matsto=1
12825 ELSE IF(i == 3) THEN ! fullMINRES
12826 metsol=4
12827 matsto=1
12828 ELSE IF(i == 4) THEN ! sparseMINRES
12829 metsol=4
12830 matsto=2
12831 ELSE IF(i == 5) THEN ! fullMINRES-QLP
12832 metsol=5
12833 matsto=1
12834 ELSE IF(i == 6) THEN ! sparseMINRES-QLP
12835 metsol=5
12836 matsto=2
12837 ELSE IF(i == 7) THEN ! decomposition
12838 metsol=3
12839 matsto=1
12840#ifdef LAPACK64
12841 ELSE IF(i == 8) THEN ! fullLAPACK factorization
12842 metsol=7
12843 matsto=1
12844 ELSE IF(i == 9) THEN ! unpackedLAPACK factorization
12845 metsol=8
12846 matsto=0
12847#ifdef PARDISO
12848 ELSE IF(i == 10) THEN ! Intel oneMKL PARDISO (sparse matrix (CSR3 or BSR3, upper triangle))
12849 metsol=9
12850 matsto=3
12851#endif
12852#endif
12853 END IF
12854 END IF
12855 END DO
12856 END IF
12857 ELSE IF(nkey == 0) THEN ! data for continuation
12858 IF(lkey == 2) THEN ! parameter
12859 IF(nums >= 3) THEN ! store data from this line
12860 lpvs=nint(dnum(1),mpi) ! label
12861 IF(lpvs /= 0) THEN
12862 CALL additem(lenparameters,listparameters,lpvs,dnum(2)) ! start value
12863 CALL additem(lenpresigmas,listpresigmas,lpvs,dnum(3)) ! pre-sigma
12864 ELSE
12865 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12866 END IF
12867 ELSE IF(nums > 1.AND.nums < 3) THEN
12868 kkey=1 ! switch to "unknown" ?
12869 WRITE(*,*) 'Wrong text in line',nline
12870 WRITE(*,*) 'Status continuation parameter'
12871 WRITE(*,*) '> ',text(1:nab)
12872 END IF
12873
12874 ELSE IF(lkey == 3) THEN ! constraint
12875 ier=0
12876 DO i=1,nums,2
12877 label=nint(dnum(i),mpi)
12878 IF(label <= 0) ier=1
12879 END DO
12880 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12881 IF(ier == 0) THEN
12882 DO i=1,nums,2
12883 lpvs=nint(dnum(i),mpi) ! label
12884 plvs=dnum(i+1) ! factor
12885 CALL additem(lenconstraints,listconstraints,lpvs,plvs)
12886 END DO
12887 ELSE
12888 kkey=0
12889 WRITE(*,*) 'Wrong text in line',nline
12890 WRITE(*,*) 'Status continuation constraint'
12891 WRITE(*,*) '> ',text(1:nab)
12892 END IF
12893
12894 ELSE IF(lkey == 4) THEN ! measurement
12895 ! WRITE(*,*) 'continuation < ',NUMS
12896 ier=0
12897 DO i=1,nums,2
12898 label=nint(dnum(i),mpi)
12899 IF(label <= 0) ier=1
12900 END DO
12901 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12902 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12903 IF(ier == 0) THEN
12904 DO i=1,nums,2
12905 lpvs=nint(dnum(i),mpi) ! label
12906 plvs=dnum(i+1) ! factor
12907 CALL additem(lenmeasurements,listmeasurements,lpvs,plvs)
12908 END DO
12909 ELSE
12910 kkey=0
12911 WRITE(*,*) 'Wrong text in line',nline
12912 WRITE(*,*) 'Status continuation measurement'
12913 WRITE(*,*) '> ',text(1:nab)
12914 END IF
12915 ELSE IF(lkey == 6) THEN ! comment
12916 IF(nums == 1) THEN
12917 lpvs=nint(dnum(1),mpi) ! label
12918 IF(lpvs /= 0) THEN
12919 ! skip label
12920 DO j=ia,ib
12921 IF (text(j:j) == ' ') EXIT
12922 END DO
12923 ctext=text(j:ib)
12924 CALL additemc(lencomments,listcomments,lpvs,ctext)
12925 ELSE
12926 WRITE(*,*) 'Line',nline,' error, label=',lpvs
12927 END IF
12928 ELSE IF(nums /= 0) THEN
12929 kkey=1 ! switch to "unknown"
12930 WRITE(*,*) 'Wrong text in line',nline
12931 WRITE(*,*) 'Status: continuation comment'
12932 WRITE(*,*) '> ',text(1:nab)
12933 END IF
12934#ifdef LAPACK64
12935#ifdef PARDISO
12936 ELSE IF(lkey == 7) THEN ! Intel oneMKL PARDISO parameters
12937 ier=0
12938 DO i=1,nums,2
12939 label=nint(dnum(i),mpi)
12940 IF(label <= 0.OR.label > 64) ier=1
12941 END DO
12942 IF(mod(nums,2) /= 0) ier=1 ! reject odd number
12943 ! WRITE(*,*) 'IER NUMS ',IER,NUMS
12944 IF(ier == 0) THEN
12945 DO i=1,nums,2
12946 lpvs=nint(dnum(i),mpi) ! label
12947 ipvs=nint(dnum(i+1),mpi) ! parameter
12948 CALL additemi(lenpardiso,listpardiso,lpvs,ipvs)
12949 END DO
12950 ELSE
12951 kkey=0
12952 WRITE(*,*) 'Wrong text in line',nline
12953 WRITE(*,*) 'Status continuation measurement'
12954 WRITE(*,*) '> ',text(1:nab)
12955 END IF
12956#endif
12957#endif
12958 END IF
12959 END IF
12960END SUBROUTINE intext
12961
12969SUBROUTINE additem(length,list,label,value)
12970 USE mpdef
12971 USE mpdalc
12972
12973 INTEGER(mpi), INTENT(IN OUT) :: length
12974 TYPE(listitem), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
12975 INTEGER(mpi), INTENT(IN) :: label
12976 REAL(mpd), INTENT(IN) :: value
12977
12978 INTEGER(mpl) :: newSize
12979 INTEGER(mpl) :: oldSize
12980 TYPE(listitem), DIMENSION(:), ALLOCATABLE :: tempList
12981
12982 IF (label > 0.AND.value == 0.) RETURN ! skip zero for valid labels
12983 IF (length == 0 ) THEN ! initial list with size = 100
12984 newsize = 100
12985 CALL mpalloc(list,newsize,' list ')
12986 ENDIF
12987 oldsize=size(list,kind=mpl)
12988 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
12989 newsize = oldsize + oldsize/5 + 100
12990 CALL mpalloc(templist,oldsize,' temp. list ')
12991 templist=list
12992 CALL mpdealloc(list)
12993 CALL mpalloc(list,newsize,' list ')
12994 list(1:oldsize)=templist(1:oldsize)
12995 CALL mpdealloc(templist)
12996 ENDIF
12997 ! add to end of list
12998 length=length+1
12999 list(length)%label=label
13000 list(length)%value=value
13001
13002END SUBROUTINE additem
13003
13011SUBROUTINE additemc(length,list,label,text)
13012 USE mpdef
13013 USE mpdalc
13014
13015 INTEGER(mpi), INTENT(IN OUT) :: length
13016 TYPE(listitemc), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
13017 INTEGER(mpi), INTENT(IN) :: label
13018 CHARACTER(len = itemCLen), INTENT(IN) :: text
13019
13020 INTEGER(mpl) :: newSize
13021 INTEGER(mpl) :: oldSize
13022 TYPE(listitemc), DIMENSION(:), ALLOCATABLE :: tempList
13023
13024 IF (label > 0.AND.text == '') RETURN ! skip empty text for valid labels
13025 IF (length == 0 ) THEN ! initial list with size = 100
13026 newsize = 100
13027 CALL mpalloc(list,newsize,' list ')
13028 ENDIF
13029 oldsize=size(list,kind=mpl)
13030 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
13031 newsize = oldsize + oldsize/5 + 100
13032 CALL mpalloc(templist,oldsize,' temp. list ')
13033 templist=list
13034 CALL mpdealloc(list)
13035 CALL mpalloc(list,newsize,' list ')
13036 list(1:oldsize)=templist(1:oldsize)
13037 CALL mpdealloc(templist)
13038 ENDIF
13039 ! add to end of list
13040 length=length+1
13041 list(length)%label=label
13042 list(length)%text=text
13043
13044END SUBROUTINE additemc
13045
13053SUBROUTINE additemi(length,list,label,ivalue)
13054 USE mpdef
13055 USE mpdalc
13056
13057 INTEGER(mpi), INTENT(IN OUT) :: length
13058 TYPE(listitemi), DIMENSION(:), INTENT(IN OUT), ALLOCATABLE :: list
13059 INTEGER(mpi), INTENT(IN) :: label
13060 INTEGER(mpi), INTENT(IN) :: ivalue
13061
13062 INTEGER(mpl) :: newSize
13063 INTEGER(mpl) :: oldSize
13064 TYPE(listitemi), DIMENSION(:), ALLOCATABLE :: tempList
13065
13066 IF (length == 0 ) THEN ! initial list with size = 100
13067 newsize = 100
13068 CALL mpalloc(list,newsize,' list ')
13069 ENDIF
13070 oldsize=size(list,kind=mpl)
13071 IF (length >= oldsize) THEN ! increase sizeby 20% + 100
13072 newsize = oldsize + oldsize/5 + 100
13073 CALL mpalloc(templist,oldsize,' temp. list ')
13074 templist=list
13075 CALL mpdealloc(list)
13076 CALL mpalloc(list,newsize,' list ')
13077 list(1:oldsize)=templist(1:oldsize)
13078 CALL mpdealloc(templist)
13079 ENDIF
13080 ! add to end of list
13081 length=length+1
13082 list(length)%label=label
13083 list(length)%ivalue=ivalue
13084
13085END SUBROUTINE additemi
13086
13088SUBROUTINE mstart(text)
13089 USE mpdef
13090 USE mpmod, ONLY: textl
13091
13092 IMPLICIT NONE
13093 INTEGER(mpi) :: i
13094 INTEGER(mpi) :: ka
13095 INTEGER(mpi) :: kb
13096 INTEGER(mpi) :: l
13097 CHARACTER (LEN=*), INTENT(IN) :: text
13098 CHARACTER (LEN=16) :: textc
13099 SAVE
13100 ! ...
13101 DO i=1,74
13102 textl(i:i)='_'
13103 END DO
13104 l=len(text)
13105 ka=(74-l)/2
13106 kb=ka+l-1
13107 textl(ka:kb)=text(1:l)
13108 WRITE(*,*) ' '
13109 WRITE(*,*) textl
13110 WRITE(*,*) ' '
13111 textc=text(1:l)//'-end'
13112
13113 DO i=1,74
13114 textl(i:i)='_'
13115 END DO
13116 l=l+4
13117 ka=(74-l)/2
13118 kb=ka+l-1
13119 textl(ka:kb)=textc(1:l)
13120 RETURN
13121END SUBROUTINE mstart
13122
13124SUBROUTINE mend
13125 USE mpmod, ONLY: textl
13126
13127 IMPLICIT NONE
13128 WRITE(*,*) ' '
13129 WRITE(*,*) textl
13130 CALL petime
13131 WRITE(*,*) ' '
13132END SUBROUTINE mend
13133
13140
13141SUBROUTINE mvopen(lun,fname)
13142 USE mpdef
13143
13144 IMPLICIT NONE
13145 INTEGER(mpi) :: l
13146 INTEGER(mpi), INTENT(IN) :: lun
13147 CHARACTER (LEN=*), INTENT(IN) :: fname
13148 CHARACTER (LEN=33) :: nafile
13149 CHARACTER (LEN=33) :: nbfile
13150 LOGICAL :: ex
13151 SAVE
13152 ! ...
13153 l=len(fname)
13154 IF(l > 32) THEN
13155 CALL peend(17,'Aborted, file name too long')
13156 stop 'File name too long '
13157 END IF
13158 nafile=fname
13159 nafile(l+1:l+1)='~'
13160
13161 INQUIRE(file=nafile(1:l),exist=ex)
13162 IF(ex) THEN
13163 INQUIRE(file=nafile(1:l+1),exist=ex)
13164 IF(ex) THEN
13165 CALL system('rm '//nafile)
13166 END IF
13167 nbfile=nafile
13168 nafile(l+1:l+1)=' '
13169 CALL system('mv '//nafile//nbfile)
13170 END IF
13171 OPEN(unit=lun,file=fname)
13172END SUBROUTINE mvopen
13173
13177
13178SUBROUTINE petime
13179 USE mpdef
13180
13181 IMPLICIT NONE
13182 REAL, DIMENSION(2) :: ta
13183 REAL etime
13184 REAL :: rst
13185 REAL :: delta
13186 REAL :: rstp
13187 REAL :: secnd1
13188 REAL :: secnd2
13189 INTEGER :: ncount
13190 INTEGER :: nhour1
13191 INTEGER :: minut1
13192 INTEGER :: nsecd1
13193 INTEGER :: nhour2
13194 INTEGER :: minut2
13195 INTEGER :: nsecd2
13196
13197 SAVE
13198 DATA ncount/0/
13199 ! ...
13200 ncount=ncount+1
13201 rst=etime(ta)
13202 IF(ncount > 1) THEN
13203 delta=rst
13204 nsecd1=int(delta,mpi) ! -> integer
13205 nhour1=nsecd1/3600
13206 minut1=nsecd1/60-60*nhour1
13207 secnd1=delta-60*(minut1+60*nhour1)
13208 delta=rst-rstp
13209 nsecd2=int(delta,mpi) ! -> integer
13210 nhour2=nsecd2/3600
13211 minut2=nsecd2/60-60*nhour2
13212 secnd2=delta-60*(minut2+60*nhour2)
13213 WRITE(*,101) nhour1,minut1,secnd1, nhour2,minut2,secnd2
13214 END IF
13215
13216 rstp=rst
13217 RETURN
13218101 FORMAT(i4,' h',i3,' min',f5.1,' sec total',18x,'elapsed', &
13219 i4,' h',i3,' min',f5.1,' sec')
13220END SUBROUTINE petime ! print
13221
13228
13229SUBROUTINE peend(icode, cmessage)
13230 USE mpdef
13231
13232 IMPLICIT NONE
13233 INTEGER(mpi), INTENT(IN) :: icode
13234 CHARACTER (LEN=*), INTENT(IN) :: cmessage
13235
13236 CALL mvopen(9,'millepede.end')
13237 WRITE(9,101) icode, cmessage
13238101 FORMAT(1x,i4,3x,a)
13239 CLOSE(9)
13240 RETURN
13241
13242END SUBROUTINE peend
13243
13250SUBROUTINE binopn(kfile, ithr, ierr)
13251 USE mpmod
13252
13253 IMPLICIT NONE
13254 INTEGER(mpi), INTENT(IN) :: kfile
13255 INTEGER(mpi), INTENT(IN) :: ithr
13256 INTEGER(mpi), INTENT(OUT) :: ierr
13257
13258 INTEGER(mpi), DIMENSION(13) :: ibuff
13259 INTEGER(mpi) :: ioff
13260 INTEGER(mpi) :: ios
13261 INTEGER(mpi) :: k
13262 INTEGER(mpi) :: lfn
13263 INTEGER(mpi) :: lun
13264 INTEGER(mpi) :: moddate
13265 CHARACTER (LEN=1024) :: fname
13266 CHARACTER (LEN=7) :: cfile
13267 INTEGER stat
13268
13269#ifdef READ_C_FILES
13270 INTERFACE
13271 SUBROUTINE openc(filename, lfn, lun, ios) BIND(c)
13272 USE iso_c_binding
13273 CHARACTER(kind=c_char), DIMENSION(*), INTENT(IN) :: filename
13274 INTEGER(c_int), INTENT(IN), VALUE :: lfn
13275 INTEGER(c_int), INTENT(IN), VALUE :: lun
13276 INTEGER(c_int), INTENT(INOUT) :: ios
13277 END SUBROUTINE openc
13278 END INTERFACE
13279#endif
13280
13281 ierr=0
13282 lun=ithr
13283 ! modification date (=0: open for first time, >0: reopen, <0: unknown )
13284 moddate=yfd(kfile)
13285 ! file name
13286 ioff=sfd(1,kfile)
13287 lfn=sfd(2,kfile)
13288 DO k=1,lfn
13289 fname(k:k)=tfd(ioff+k)
13290 END DO
13291 !print *, " opening binary ", kfile, ithr, moddate, " : ", fname(1:lfn)
13292 ! open
13293 ios=0
13294 IF(kfile <= nfilf) THEN
13295 ! Fortran file
13296 lun=kfile+10
13297 OPEN(lun,file=fname(1:lfn),iostat=ios, form='UNFORMATTED')
13298 print *, ' lun ', lun, ios
13299#ifdef READ_C_FILES
13300 ELSE
13301 ! C file
13302 CALL openc(fname(1:lfn),lfn,lun,ios)
13303#else
13304 WRITE(*,*) 'Opening of C-files not supported.'
13305 ierr=1
13306 RETURN
13307#endif
13308 END IF
13309 IF(ios /= 0) THEN
13310 ierr=1
13311 WRITE(*,*) 'Open error for file ',fname(1:lfn), ios
13312 IF (moddate /= 0) THEN
13313 WRITE(cfile,'(I7)') kfile
13314 CALL peend(15,'Aborted, open error(s) for binary file ' // cfile)
13315 stop 'PEREAD: open error'
13316 ENDIF
13317 RETURN
13318 END IF
13319 ! get status
13320 ios=stat(fname(1:lfn),ibuff)
13321 !print *, ' STAT ', ios, ibuff(10), moddate
13322 IF(ios /= 0) THEN
13323 ierr=1
13324 WRITE(*,*) 'STAT error for file ',fname(1:lfn), ios
13325 ibuff(10)=-1
13326 END IF
13327 ! check/store modification date
13328 IF (moddate /= 0) THEN
13329 IF (ibuff(10) /= moddate) THEN
13330 WRITE(cfile,'(I7)') kfile
13331 CALL peend(19,'Aborted, binary file modified (date) ' // cfile)
13332 stop 'PEREAD: file modified'
13333 END IF
13334 ELSE
13335 yfd(kfile)=ibuff(10)
13336 END IF
13337 RETURN
13338
13339END SUBROUTINE binopn
13340
13346SUBROUTINE bincls(kfile, ithr)
13347 USE mpmod
13348
13349 IMPLICIT NONE
13350 INTEGER(mpi), INTENT(IN) :: kfile
13351 INTEGER(mpi), INTENT(IN) :: ithr
13352
13353 INTEGER(mpi) :: lun
13354
13355#ifdef READ_C_FILES
13356 INTERFACE
13357 SUBROUTINE closec(lun) BIND(c)
13358 USE iso_c_binding
13359 INTEGER(c_int), INTENT(IN), VALUE :: lun
13360 END SUBROUTINE closec
13361 END INTERFACE
13362#endif
13363
13364 lun=ithr
13365 !print *, " closing binary ", kfile, ithr
13366 IF(kfile <= nfilf) THEN ! Fortran file
13367 lun=kfile+10
13368 CLOSE(lun)
13369#ifdef READ_C_FILES
13370 ELSE ! C file
13371 CALL closec(lun)
13372#endif
13373 END IF
13374
13375END SUBROUTINE bincls
13376
13381SUBROUTINE binrwd(kfile)
13382 USE mpmod
13383
13384 IMPLICIT NONE
13385 INTEGER(mpi), INTENT(IN) :: kfile
13386
13387 INTEGER(mpi) :: lun
13388
13389#ifdef READ_C_FILES
13390 INTERFACE
13391 SUBROUTINE resetc(lun) BIND(c)
13392 USE iso_c_binding
13393 INTEGER(c_int), INTENT(IN), VALUE :: lun
13394 END SUBROUTINE resetc
13395 END INTERFACE
13396#endif
13397
13398 !print *, " rewinding binary ", kfile
13399 IF (kfile <= nfilf) THEN
13400 lun=kfile+10
13401 rewind lun
13402#ifdef READ_C_FILES
13403 ELSE
13404 lun=kfile-nfilf
13405 CALL resetc(lun)
13406#endif
13407 END IF
13408
13409END SUBROUTINE binrwd
13410
13412SUBROUTINE ckpgrp
13413 USE mpmod
13414 USE mpdalc
13415
13416 IMPLICIT NONE
13417 INTEGER(mpi) :: i
13418 INTEGER(mpi) :: ipgrp
13419 INTEGER(mpi) :: irank
13420 INTEGER(mpi) :: isize
13421 INTEGER(mpi) :: ivoff
13422 INTEGER(mpi) :: itgbi
13423 INTEGER(mpi) :: j
13424 INTEGER(mpi) :: msize
13425 INTEGER(mpi), PARAMETER :: mxsize = 1000
13426 INTEGER(mpl):: ij
13427 INTEGER(mpl):: length
13428
13429 REAL(mpd), DIMENSION(:), ALLOCATABLE :: auxVectorD
13430 INTEGER(mpi), DIMENSION(:), ALLOCATABLE :: auxVectorI
13431 REAL(mpd), DIMENSION(:), ALLOCATABLE :: resParGroup
13432 REAL(mpd), DIMENSION(:), ALLOCATABLE :: blockParGroup
13433 REAL(mpd) :: matij
13434 SAVE
13435
13436 ! maximal group size
13437 msize=0
13438 DO ipgrp=1,nvpgrp
13439 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13440 IF (isize <= mxsize) THEN
13441 msize=max(msize,isize)
13442 ELSE
13443 print *, ' CKPGRP: par. group', ipgrp, ' not checked -- too large: ', isize
13444 END IF
13445 END DO
13446 IF (msize == 0) RETURN
13447
13448 ! (matrix) block for parameter groups
13449 length=int(msize,mpl)*(int(msize,mpl)+1)/2
13450 CALL mpalloc(blockpargroup,length,'(matrix) block for parameter groups (D)')
13451 length=msize
13452 CALL mpalloc(respargroup,length,'residuals for parameter groups (D)') ! double aux 1
13453 CALL mpalloc(auxvectori,length,'auxiliary array (I)') ! int aux 1
13454 CALL mpalloc(auxvectord,length,'auxiliary array (D)') ! double aux 1
13455
13456 respargroup=0
13457 print *
13458 print *,' CKPGRP par. group first label size rank'
13459 DO ipgrp=1,nvpgrp
13460 isize=globalallindexgroups(ipgrp+1)-globalallindexgroups(ipgrp)
13461 IF (isize > mxsize) cycle
13462 ! copy matrix block
13463 ivoff=globalallindexgroups(ipgrp)-1
13464 ij=0
13465 DO i=1,isize
13466 DO j=1,i
13467 ij=ij+1
13468 blockpargroup(ij)=matij(ivoff+i,ivoff+j)
13469 END DO
13470 END DO
13471 ! inversion of matrix block
13472 CALL sqminv(blockpargroup,respargroup,isize,irank, auxvectord, auxvectori)
13473 !
13475 IF (isize == irank) THEN
13476 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank
13477 ELSE
13478 ndefpg=ndefpg+1
13479 print *,' CKPGRP ', ipgrp, globalparlabelindex(1,itgbi), isize, irank, ' rank deficit !!!'
13480 END IF
13481 END DO
13482
13483 ! clean up
13484 CALL mpdealloc(auxvectord)
13485 CALL mpdealloc(auxvectori)
13486 CALL mpdealloc(respargroup)
13487 CALL mpdealloc(blockpargroup)
13488
13489END SUBROUTINE ckpgrp
13490
13492SUBROUTINE chkmat
13493 USE mpmod
13494
13495 IMPLICIT NONE
13496 INTEGER(mpl) :: i
13497 INTEGER(mpl) :: nan
13498 INTEGER(mpl) :: neg
13499
13500 print *, ' Checking global matrix(D) for NANs ', size(globalmatd,kind=mpl)
13501 nan=0
13502 DO i=1,size(globalmatd,kind=mpl)
13503 IF(.NOT.(globalmatd(i) <= 0.0_mpd).AND..NOT.(globalmatd(i) > 0.0_mpd)) THEN
13504 nan=nan+1
13505 print *, ' i, nan ', i, nan
13506 END IF
13507 END DO
13508
13509 IF (matsto > 1) RETURN
13510 print *
13511 print *, ' Checking diagonal elements ', nagb
13512 neg=0
13513 DO i=1,nagb
13514 IF(.NOT.(globalmatd(globalrowoffsets(i)+i) > 0.0_mpd)) THEN
13515 neg=neg+1
13516 print *, ' i, neg ', i, neg
13517 END IF
13518 END DO
13519 print *
13520 print *, ' CHKMAT summary ', nan, neg
13521 print *
13522
13523END SUBROUTINE chkmat
13524
13525
13526! ----- accurate summation ----(from mpnum) ---------------------------------
13527
13537
13538SUBROUTINE addsums(ithrd, chi2, ndf, dw)
13539 USE mpmod
13540
13541 IMPLICIT NONE
13542 REAL(mpd), INTENT(IN) :: chi2
13543 INTEGER(mpi), INTENT(IN) :: ithrd
13544 INTEGER(mpi), INTENT(IN) :: ndf
13545 REAL(mpd), INTENT(IN) :: dw
13546
13547 INTEGER(mpl) ::nadd
13548 REAL(mpd) ::add
13549 ! ...
13550 add=chi2*dw ! apply (file) weight
13551 nadd=int(add,mpl) ! convert to integer
13552 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+nadd ! sum integer
13553 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)+(add-real(nadd,mpd)) ! sum remainder
13554 IF(globalchi2sumd(ithrd) > 16.0_mpd) THEN ! + - 16
13555 globalchi2sumd(ithrd)=globalchi2sumd(ithrd)-16.0_mpd
13556 globalchi2sumi(ithrd)=globalchi2sumi(ithrd)+16_mpl
13557 END IF
13558 globalndfsum(ithrd)=globalndfsum(ithrd)+int(ndf,mpl)
13559 globalndfsumw(ithrd)=globalndfsumw(ithrd)+real(ndf,mpd)*dw
13560 RETURN
13561END SUBROUTINE addsums
13562
13570
13571SUBROUTINE getsums(chi2, ndf, wndf)
13572 USE mpmod
13573
13574 IMPLICIT NONE
13575 REAL(mpd), INTENT(OUT) ::chi2
13576 INTEGER(mpl), INTENT(OUT) ::ndf
13577 REAL(mpd), INTENT(OUT) ::wndf
13578 ! ...
13579 chi2=sum(globalchi2sumd)+real(sum(globalchi2sumi),mpd)
13580 ndf=sum(globalndfsum)
13581 wndf=sum(globalndfsumw)
13582 globalchi2sumd=0.0_mpd
13583 globalchi2sumi=0_mpl
13584 globalndfsum=0_mpl
13585 globalndfsumw=0.0_mpd
13586 RETURN
13587END 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:3870
subroutine mchdec
Solution by Cholesky decomposition.
Definition: pede.f90:9057
subroutine bincls(kfile, ithr)
Close binary file.
Definition: pede.f90:13347
subroutine prpcon
Prepare constraints.
Definition: pede.f90:1954
subroutine mminrs
Solution with MINRES.
Definition: pede.f90:10131
subroutine prtrej(lun)
Print rejection statistics.
Definition: pede.f90:5388
subroutine mcsolv(n, x, y)
Solution for zero band width preconditioner.
Definition: pede.f90:10335
subroutine mupdat(i, j, add)
Update element of global matrix.
Definition: pede.f90:4092
subroutine peend(icode, cmessage)
Print exit code.
Definition: pede.f90:13230
subroutine loopn
Loop with fits and sums.
Definition: pede.f90:3435
subroutine loop1
First data loop (get global labels).
Definition: pede.f90:6939
subroutine feasma
Matrix for feasible solution.
Definition: pede.f90:2254
subroutine xloopn
Standard solution algorithm.
Definition: pede.f90:10389
subroutine ploopa(lunp)
Print title for iteration.
Definition: pede.f90:3849
subroutine isjajb(nst, is, ja, jb, jsp)
Decode Millepede record.
Definition: pede.f90:3384
subroutine additem(length, list, label, value)
add item to list
Definition: pede.f90:12970
subroutine mgupdt(i, j1, j2, il, jl, n, sub)
Update global matrix for parameter group.
Definition: pede.f90:4177
subroutine lpavat(t)
Similarity transformation by Q(t).
Definition: pede.f90:9619
subroutine binrwd(kfile)
Rewind binary file.
Definition: pede.f90:13382
subroutine zdiags
Covariance matrix for diagonalization (,correction of eigenvectors).
Definition: pede.f90:10094
subroutine solglo(ivgbi)
Error for single global parameter from MINRES.
Definition: pede.f90:1415
subroutine upone
Update, redefine hash indices.
Definition: pede.f90:6805
subroutine pargrp(inds, inde)
Parameter group info update for block of parameters.
Definition: pede.f90:3267
subroutine prtglo
Print final log file.
Definition: pede.f90:5417
subroutine monres
Monitor input residuals.
Definition: pede.f90:8640
subroutine intext(text, nline)
Interprete text.
Definition: pede.f90:12093
integer(mpl) function ijadd(itema, itemb)
Index for sparse storage (custom).
Definition: pede.f90:6438
subroutine mdiags
Solution by diagonalization.
Definition: pede.f90:9945
program mptwo
Millepede II main program Pede.
Definition: pede.f90:910
subroutine prtstat
Print input statistic.
Definition: pede.f90:5604
real(mpd) function matij(itema, itemb)
Get matrix element at (i,j).
Definition: pede.f90:6545
subroutine grpcon
Group constraints.
Definition: pede.f90:1656
subroutine loopbf(nrej, numfil, naccf, chi2f, ndff)
Loop over records in read buffer (block), fits and sums.
Definition: pede.f90:4345
subroutine peread(more)
Read (block of) records from binary files.
Definition: pede.f90:2590
subroutine filetx
Interprete text files.
Definition: pede.f90:11770
integer(mpi) function iprime(n)
largest prime number < N.
Definition: pede.f90:6907
subroutine ploopc(lunp)
Print sub-iteration line.
Definition: pede.f90:3927
integer(mpl) function ijcsr3(itema, itemb)
Index for sparse storage (CSR3).
Definition: pede.f90:6487
subroutine useone
Make usable (sort items and redefine hash indices).
Definition: pede.f90:6875
subroutine mvopen(lun, fname)
Open file.
Definition: pede.f90:13142
subroutine chkrej
Check rejection details.
Definition: pede.f90:11230
subroutine avprd0(n, l, x, b)
Product symmetric (sub block) matrix times vector.
Definition: pede.f90:6009
subroutine addsums(ithrd, chi2, ndf, dw)
Accurate summation.
Definition: pede.f90:13539
subroutine solgloqlp(ivgbi)
Error for single global parameter from MINRES-QLP.
Definition: pede.f90:1499
subroutine lpqldec(a, emin, emax)
QL decomposition.
Definition: pede.f90:9497
subroutine addcst
Add constraint information to matrix and vector.
Definition: pede.f90:1582
subroutine petime
Print times.
Definition: pede.f90:13179
subroutine mstart(text)
Start of 'module' printout.
Definition: pede.f90:13089
subroutine mend
End of 'module' printout.
Definition: pede.f90:13125
subroutine anasps
Analyse sparsity structure.
Definition: pede.f90:6177
subroutine minver
Solution by matrix inversion.
Definition: pede.f90:8944
subroutine peprep(mode)
Prepare records.
Definition: pede.f90:2940
integer(mpi) function ijprec(itema, itemb)
Precision for storage of parameter groups.
Definition: pede.f90:6409
subroutine explfc(lunit)
Print explanation of iteration table.
Definition: pede.f90:4001
subroutine getsums(chi2, ndf, wndf)
Get accurate sums.
Definition: pede.f90:13572
subroutine chkmat
Check global matrix.
Definition: pede.f90:13493
subroutine binopn(kfile, ithr, ierr)
Open binary file.
Definition: pede.f90:13251
subroutine pepgrp
Parameter group info update.
Definition: pede.f90:3113
subroutine sechms(deltat, nhour, minut, secnd)
Time conversion.
Definition: pede.f90:6690
integer(mpi) function inone(item)
Translate labels to indices (for global parameters).
Definition: pede.f90:6735
subroutine avprds(n, l, x, is, ie, b)
Product symmetric (sub block) matrix times sparse vector.
Definition: pede.f90:5795
subroutine avprod(n, x, b)
Product symmetric matrix times vector.
Definition: pede.f90:6271
subroutine ijpgrp(itema, itemb, ij, lr, iprc)
Index (region length and precision) for sparse storage of parameter groups.
Definition: pede.f90:6311
subroutine loop1i
Iteration of first data loop.
Definition: pede.f90:7306
subroutine mhalf2
Fill 2nd half of matrix for extended storage.
Definition: pede.f90:6603
subroutine ckpgrp
Check (rank of) parameter groups.
Definition: pede.f90:13413
subroutine additemi(length, list, label, ivalue)
add item to list
Definition: pede.f90:13054
subroutine mminrsqlp
Solution with MINRES-QLP.
Definition: pede.f90:10229
subroutine filetc
Interprete command line option, steering file.
Definition: pede.f90:11294
subroutine feasib(concut, iact)
Make parameters feasible.
Definition: pede.f90:2429
subroutine mspardiso
Solution with Intel(R) oneAPI Math Kernel Library (oneMKL) PARDISO.
Definition: pede.f90:9716
subroutine mdutrf
Solution by factorization.
Definition: pede.f90:9316
subroutine mdptrf
Solution by factorization.
Definition: pede.f90:9169
subroutine mvsolv(n, x, y)
Solution for finite band width preconditioner.
Definition: pede.f90:10356
subroutine vmprep(msize)
Prepare storage for vectors and matrices.
Definition: pede.f90:8747
subroutine ploopd(lunp)
Print solution line.
Definition: pede.f90:3975
subroutine pechk(ibuf, nerr)
Check Millepede record.
Definition: pede.f90:3041
subroutine loop2
Second data loop (number of derivatives, global label pairs).
Definition: pede.f90:7418
integer(mpi) function nufile(fname)
Inquire on file.
Definition: pede.f90:12036
subroutine additemc(length, list, label, text)
add character item to list
Definition: pede.f90:13012
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