Millepede-II V04-17-03
mp1to2.f90
Go to the documentation of this file.
1! Code converted using TO_F90 by Alan Miller
2! Date: 2024-04-25 Time: 15:10:45
3
43
50SUBROUTINE initgl(nagbar,nalcar,nstd,iprlim)
51 ! ------------------------------------------------------------------
52 ! Basic dimension parameters
53
54 INTEGER, INTENT(IN) :: nagbar
55 INTEGER, INTENT(IN) :: nalcar
56 INTEGER, INTENT(IN OUT) :: nstd
57 INTEGER, INTENT(IN) :: iprlim
58 INTEGER, PARAMETER :: mglobl=1400
59 INTEGER, PARAMETER :: mlocal=10
60 INTEGER, PARAMETER :: nstore=10000
61 INTEGER, PARAMETER :: mcs=10
62 INTEGER, PARAMETER :: mgl=mglobl+mcs
63 ! derived parameters
64 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
65 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
66 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
67 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
68 INTEGER, PARAMETER :: mglocs= mglobl*mcs
69 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
70 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
71 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
72 LOGICAL :: scflag
73 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
74 diag(mgl),bgvec(mgl),blvec(mlocal), &
75 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
76 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
77 scdiag(mglobl),summ,scflag(mglobl), &
78 indgb(mglobl),indlc(mlocal),loctot,locrej, &
79 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
80 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
81 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
82 ! ------------------------------------------------------------------
83 INTEGER :: ndr(7)
84 DATA ndr/1,2,5,10,20,50,100/
85 ! ...
86 icnlim=iprlim
87 IF(icnlim >= 0) WRITE(*,199)
88199 FORMAT( ' MP-I to MP-II interface: create steering, binary files'/ &
89 ' '/ &
90 ' * o o o '/ &
91 ' o o o '/ &
92 ' o ooooo o o o oo ooo oo ooo oo '/ &
93 ' o o o o o o o o o o o o o o o o '/ &
94 ' o o o o o o oooo o o oooo o o oooo '/ &
95 ' o o o o o o o ooo o o o o '/ &
96 ' o o o o oo oo oo o oo ooo oo starting'/ &
97 ' o ')
98 lunit=51 ! unit for binary file
99 ncs =0 ! number of constraints
100 nagb=nagbar
101 nalc=nalcar
102 IF(icnlim >= 0) THEN
103 WRITE(*,*) ' '
104 WRITE(*,*) 'Number of global parameters ',nagb
105 WRITE(*,*) 'Number of local parameters ',nalc
106 END IF
107 IF(nstd /= 3) THEN
108 WRITE(*,*) ' '
109 WRITE(*,*) 'MP-II uses nstd=3 istead of ',nstd
110 END IF
111 WRITE(*,*) ' '
112
113 IF(nagb > mglobl.OR.nalc > mlocal) THEN
114 WRITE(*,*) 'Too many parameter - STOP'
115 stop
116 END IF
117 ! reset input for global variables
118 DO i=1,nagb
119 pparm(i)=0.0 ! previous values of parameters set to zero
120 psigm(i)=-1.0 ! no sigma defined for parameter I
121 END DO
122 ! open binary file
123 OPEN(unit=lunit,access='SEQUENTIAL',form='UNFORMATTED', file='mp2tst.bin')
124 ! output buffer
125 nst=1
126 indst(nst)=0
127 arest(nst)=0.
128END SUBROUTINE initgl
129
133SUBROUTINE parglo(par)
134 ! ------------------------------------------------------------------
135 ! Basic dimension parameters
136
137 REAL, INTENT(IN) :: par(*)
138 INTEGER, PARAMETER :: mglobl=1400
139 INTEGER, PARAMETER :: mlocal=10
140 INTEGER, PARAMETER :: nstore=10000
141 INTEGER, PARAMETER :: mcs=10
142 INTEGER, PARAMETER :: mgl=mglobl+mcs
143 ! derived parameters
144 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
145 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
146 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
147 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
148 INTEGER, PARAMETER :: mglocs= mglobl*mcs
149 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
150 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
151 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
152 LOGICAL :: scflag
153 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
154 diag(mgl),bgvec(mgl),blvec(mlocal), &
155 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
156 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
157 scdiag(mglobl),summ,scflag(mglobl), &
158 indgb(mglobl),indlc(mlocal),loctot,locrej, &
159 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
160 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
161 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
162 ! ------------------------------------------------------------------
163
164
165 DO i=1,nagb
166 pparm(i)=par(i)
167 END DO
168END SUBROUTINE parglo
169
171SUBROUTINE parsig(INDEX,sigma)
172 ! ------------------------------------------------------------------
173 ! Basic dimension parameters
174
175 INTEGER, INTENT(IN) :: INDEX
176 REAL, INTENT(IN) :: sigma
177 INTEGER, PARAMETER :: mglobl=1400
178 INTEGER, PARAMETER :: mlocal=10
179 INTEGER, PARAMETER :: nstore=10000
180 INTEGER, PARAMETER :: mcs=10
181 INTEGER, PARAMETER :: mgl=mglobl+mcs
182 ! derived parameters
183 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
184 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
185 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
186 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
187 INTEGER, PARAMETER :: mglocs= mglobl*mcs
188 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
189 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
190 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
191 LOGICAL :: scflag
192 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
193 diag(mgl),bgvec(mgl),blvec(mlocal), &
194 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
195 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
196 scdiag(mglobl),summ,scflag(mglobl), &
197 indgb(mglobl),indlc(mlocal),loctot,locrej, &
198 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
199 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
200 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
201 ! ------------------------------------------------------------------
202 IF(index < 1.OR.index > nagb) RETURN
203 IF(sigma < 0.0) RETURN
204 psigm(index)=sigma
205END SUBROUTINE parsig
206
208SUBROUTINE nonlin(INDEX)
209 ! ------------------------------------------------------------------
210 ! Basic dimension parameters
211
212 INTEGER, INTENT(IN) :: INDEX
213 INTEGER, PARAMETER :: mglobl=1400
214 INTEGER, PARAMETER :: mlocal=10
215 INTEGER, PARAMETER :: nstore=10000
216 INTEGER, PARAMETER :: mcs=10
217 INTEGER, PARAMETER :: mgl=mglobl+mcs
218 ! derived parameters
219 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
220 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
221 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
222 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
223 INTEGER, PARAMETER :: mglocs= mglobl*mcs
224 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
225 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
226 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
227 LOGICAL :: scflag
228 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
229 diag(mgl),bgvec(mgl),blvec(mlocal), &
230 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
231 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
232 scdiag(mglobl),summ,scflag(mglobl), &
233 indgb(mglobl),indlc(mlocal),loctot,locrej, &
234 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
235 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
236 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
237 ! ------------------------------------------------------------------
238 IF(index < 1.OR.index > nagb) RETURN
239 nlnpa(index)=1
240END SUBROUTINE nonlin
241
243SUBROUTINE initun(lun,cutfac)
244 WRITE(*,*) ' INITUN is dummy !', lun, cutfac
245END SUBROUTINE initun
246
248SUBROUTINE constf(dercs,rhs)
249 ! ------------------------------------------------------------------
250 ! Basic dimension parameters
251
252 REAL, INTENT(IN) :: dercs(*)
253 REAL, INTENT(IN) :: rhs
254 INTEGER, PARAMETER :: mglobl=1400
255 INTEGER, PARAMETER :: mlocal=10
256 INTEGER, PARAMETER :: nstore=10000
257 INTEGER, PARAMETER :: mcs=10
258 INTEGER, PARAMETER :: mgl=mglobl+mcs
259 ! derived parameters
260 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
261 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
262 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
263 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
264 INTEGER, PARAMETER :: mglocs= mglobl*mcs
265 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
266 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
267 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
268 LOGICAL :: scflag
269 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
270 diag(mgl),bgvec(mgl),blvec(mlocal), &
271 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
272 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
273 scdiag(mglobl),summ,scflag(mglobl), &
274 indgb(mglobl),indlc(mlocal),loctot,locrej, &
275 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
276 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
277 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
278 ! ------------------------------------------------------------------
279
280
281 IF(ncs >= mcs) stop '<INITCS> too many constraints'
282 DO i=1,nagb
283 adercs(nagb*ncs+i)=dercs(i)
284 END DO
285 ncs=ncs+1
286 arhs(ncs)=rhs
287END SUBROUTINE constf
288
296SUBROUTINE equloc(dergb,derlc,rrmeas,sigma)
297
298 REAL, INTENT(OUT) :: dergb(*)
299 REAL, INTENT(OUT) :: derlc(*)
300 REAL, INTENT(IN) :: rrmeas
301 REAL, INTENT(IN) :: sigma
302 ! ------------------------------------------------------------------
303 ! Basic dimension parameters
304 INTEGER, PARAMETER :: mglobl=1400
305 INTEGER, PARAMETER :: mlocal=10
306 INTEGER, PARAMETER :: nstore=10000
307 INTEGER, PARAMETER :: mcs=10
308 INTEGER, PARAMETER :: mgl=mglobl+mcs
309 ! derived parameters
310 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
311 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
312 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
313 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
314 INTEGER, PARAMETER :: mglocs= mglobl*mcs
315 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
316 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
317 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
318 LOGICAL :: scflag
319 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
320 diag(mgl),bgvec(mgl),blvec(mlocal), &
321 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
322 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
323 scdiag(mglobl),summ,scflag(mglobl), &
324 indgb(mglobl),indlc(mlocal),loctot,locrej, &
325 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
326 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
327 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
328 ! ------------------------------------------------------------------
329
330 ! ...
331 rmeas=rrmeas
332 IF(sigma <= 0.0) THEN
333 DO i=1,nalc ! local parameters
334 derlc(i)=0.0 ! reset
335 END DO
336 DO i=1,nagb ! global parameters
337 dergb(i)=0.0 ! reset
338 END DO
339 RETURN
340 END IF
341 nonzer=0
342 ialc=0
343 iblc=-1
344 DO i=1,nalc ! count number of local parameters
345 IF(derlc(i) /= 0.0) THEN
346 nonzer=nonzer+1
347 IF(ialc == 0) ialc=i ! first and last index
348 iblc=i
349 END IF
350 END DO
351 iagb=0
352 ibgb=-1
353 DO i=1,nagb ! ... plus global parameters
354 IF(dergb(i) /= 0.0) THEN
355 nonzer=nonzer+1
356 IF(iagb == 0) iagb=i ! first and last index
357 ibgb=i
358 END IF
359 END DO
360 IF(nst+nonzer+2 >= nstore) THEN
361 nfl=1 ! set overflow flag
362 RETURN ! ignore data
363 END IF
364 nst=nst+1
365 indst(nst)=0
366 arest(nst)=rmeas
367 DO i=ialc,iblc ! local parameters
368 IF(derlc(i) /= 0.0) THEN
369 nst=nst+1
370 indst(nst)=i ! store index ...
371 arest(nst)=derlc(i) ! ... and value of nonzero derivative
372 derlc(i)=0.0 ! reset
373 END IF
374 END DO
375 nst=nst+1
376 indst(nst)=0
377 arest(nst)=sigma
378 DO i=iagb,ibgb ! global parameters
379 IF(dergb(i) /= 0.0) THEN
380 nst=nst+1
381 indst(nst)=i ! store index ...
382 arest(nst)=dergb(i) ! ... and value of nonzero derivative
383 dergb(i)=0.0 ! reset
384 END IF
385 END DO
386END SUBROUTINE equloc
387
392SUBROUTINE zerloc(dergb,derlc)
393
394 REAL, INTENT(OUT) :: dergb(*)
395 REAL, INTENT(OUT) :: derlc(*)
396 ! ------------------------------------------------------------------
397 ! Basic dimension parameters
398 INTEGER, PARAMETER :: mglobl=1400
399 INTEGER, PARAMETER :: mlocal=10
400 INTEGER, PARAMETER :: nstore=10000
401 INTEGER, PARAMETER :: mcs=10
402 INTEGER, PARAMETER :: mgl=mglobl+mcs
403 ! derived parameters
404 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
405 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
406 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
407 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
408 INTEGER, PARAMETER :: mglocs= mglobl*mcs
409 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
410 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
411 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
412 LOGICAL :: scflag
413 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
414 diag(mgl),bgvec(mgl),blvec(mlocal), &
415 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
416 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
417 scdiag(mglobl),summ,scflag(mglobl), &
418 indgb(mglobl),indlc(mlocal),loctot,locrej, &
419 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
420 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
421 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
422 ! ------------------------------------------------------------------
423
424
425 DO i=1,nalc ! local parameters
426 derlc(i)=0.0 ! reset
427 END DO
428 DO i=1,nagb ! global parameters
429 dergb(i)=0.0 ! reset
430 END DO
431END SUBROUTINE zerloc
432
434SUBROUTINE fitloc
435 ! faster(?) version
436 ! ------------------------------------------------------------------
437 ! Basic dimension parameters
438 INTEGER, PARAMETER :: mglobl=1400
439 INTEGER, PARAMETER :: mlocal=10
440 INTEGER, PARAMETER :: nstore=10000
441 INTEGER, PARAMETER :: mcs=10
442 INTEGER, PARAMETER :: mgl=mglobl+mcs
443 ! derived parameters
444 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
445 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
446 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
447 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
448 INTEGER, PARAMETER :: mglocs= mglobl*mcs
449 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
450 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
451 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
452 LOGICAL :: scflag
453 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
454 diag(mgl),bgvec(mgl),blvec(mlocal), &
455 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
456 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
457 scdiag(mglobl),summ,scflag(mglobl), &
458 indgb(mglobl),indlc(mlocal),loctot,locrej, &
459 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
460 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
461 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
462 ! ------------------------------------------------------------------
463
464
465 IF(nst > 1) THEN ! write to binary file
466 WRITE(lunit) nst*2,(arest(i),i=1,nst),(indst(i),i=1,nst)
467 END IF
468
469 entry killoc
470 IF(itert <= 1) THEN
471 ! histogram of used store space
472 IF(nfl == 0) THEN
473 ibin=int(1.0+50.0*float(nst)/float(nstore))
474 ibin=min(ibin,50)
475 khist(ibin)=khist(ibin)+1
476 ELSE
477 khist(51)=khist(51)+1
478 END IF
479 END IF
480 nst=1 ! reset counter
481 nfl=0 ! reset overflow flag
482END SUBROUTINE fitloc
483
485SUBROUTINE fitglo(par)
486
487 REAL, INTENT(IN OUT) :: par(*)
488
489 ! ------------------------------------------------------------------
490 ! Basic dimension parameters
491 INTEGER, PARAMETER :: mglobl=1400
492 INTEGER, PARAMETER :: mlocal=10
493 INTEGER, PARAMETER :: nstore=10000
494 INTEGER, PARAMETER :: mcs=10
495 INTEGER, PARAMETER :: mgl=mglobl+mcs
496 ! derived parameters
497 INTEGER, PARAMETER :: msymgb =(mglobl*mglobl+mglobl)/2
498 INTEGER, PARAMETER :: msym =(mgl*mgl+mgl)/2
499 INTEGER, PARAMETER :: msymlc=(mlocal*mlocal+mlocal)/2
500 INTEGER, PARAMETER :: mrecta= mglobl*mlocal
501 INTEGER, PARAMETER :: mglocs= mglobl*mcs
502 INTEGER, PARAMETER :: msymcs= (mcs*mcs+mcs)/2
503 DOUBLE PRECISION :: cgmat,clmat,clcmat,bgvec,blvec, &
504 corrm,corrv,summ,diag,scdiag,pparm,dparm,adercs, arhs
505 LOGICAL :: scflag
506 common/lsqred/cgmat(msym),clmat(msymlc),clcmat(mrecta), &
507 diag(mgl),bgvec(mgl),blvec(mlocal), &
508 corrm(msymgb),corrv(mglobl),psigm(mglobl), &
509 pparm(mglobl),adercs(mglocs),arhs(mcs), dparm(mglobl), &
510 scdiag(mglobl),summ,scflag(mglobl), &
511 indgb(mglobl),indlc(mlocal),loctot,locrej, &
512 nagb,nalc,nsum,nhist,mhist(51),khist(51),lhist(51), &
513 nst,nfl,indst(nstore),arest(nstore),itert,lunit,ncs, &
514 nlnpa(mglobl),nstdev,cfactr,icnpr,icnlim
515 ! ------------------------------------------------------------------
516 ! close binary file
517 CLOSE(lunit)
518 ! count parameter settings
519 npar=0
520 DO i=1,nagb ! global parameters
521 IF (pparm(i) /= 0.0.OR.psigm(i) >= 0.0) npar=npar+1
522 par(i)=0.
523 END DO
524 ! create steering file
525 luns=7
526 OPEN(unit=luns,access='SEQUENTIAL',form='FORMATTED', file='mp2str.txt')
527 WRITE(luns,101) '* Default test steering file'
528 WRITE(luns,101) 'fortranfiles ! following bin files are fortran'
529 WRITE(luns,101) 'mp2tst.bin ! binary data file'
530 WRITE(luns,101) ' '
531 IF(ncs > 0) THEN
532 WRITE(luns,101) 'mp2con.txt ! constraints text file '
533 WRITE(luns,101) ' '
534 END IF
535 IF(npar > 0) THEN
536 WRITE(luns,101) 'Parameter ! with start values or pre-sigma'
537 DO i=1,nagb ! global parameters
538 IF (pparm(i) /= 0.0.OR.psigm(i) >= 0.0) THEN
539 presig=psigm(i)
540 ! parameter fixed by PRESIG = 0 (MP1) -> <0 (MP2)
541 IF (presig == 0.0) presig=-1.0
542 WRITE(luns,103) i, pparm(i), presig
543 END IF
544 END DO
545 WRITE(luns,101) ' '
546 END IF
547 WRITE(luns,101) 'chisqcut 30.0 6.0 ! Chi2/ndf cut factors'
548 WRITE(luns,101) 'method inversion 3 0.001 ! Gauss matrix inversion'
549 WRITE(luns,101) ' '
550 WRITE(luns,101) 'end ! optional for end-of-data'
551 CLOSE(luns)
552 ! create constraints file
553 IF (ncs > 0) THEN
554 lunc=9
555 OPEN(unit=lunc,access='SEQUENTIAL',form='FORMATTED', file='mp2con.txt')
556 DO i=0, ncs-1
557 WRITE(lunc,101) 'Constraint 0.0'
558 DO j=1,nagb
559 IF (adercs(nagb*i+j) /= 0.0) WRITE(lunc,102) j, adercs(nagb*i+j)
560 END DO
561 END DO
562 CLOSE(lunc)
563 END IF
564 WRITE(*,199)
565199 FORMAT( ' '/ &
566 ' * o o o '/ &
567 ' o o o '/ &
568 ' o ooooo o o o oo ooo oo ooo oo '/ &
569 ' o o o o o o o o o o o o o o o o '/ &
570 ' o o o o o o oooo o o oooo o o oooo '/ &
571 ' o o o o o o o ooo o o o o '/ &
572 ' o o o o oo oo oo o oo ooo oo ending.'/ &
573 ' o '/ &
574 ' '/ &
575 ' MP-I to MP-II interface: create steering, binary files')
576101 FORMAT(a)
577102 FORMAT(i8,f10.5)
578103 FORMAT(i8,2f10.5)
579
580END SUBROUTINE fitglo
581
583FUNCTION errpar(i)
584 errpar=0.0
585 WRITE(*,*) ' ERRPAR is dummy !', i
586END FUNCTION errpar
587
589FUNCTION corpar(i,j)
590 corpar=0.0
591 WRITE(*,*) ' CORPAR is dummy !', i, j
592END FUNCTION corpar
593
595SUBROUTINE prtglo(lun)
596 WRITE(*,*) ' PRTGLO is dummy !', lun
597END SUBROUTINE prtglo
initgl
subroutine initgl(nagbar, nalcar, nstd, iprlim)
Initialization of package.
Definition: millepede1.f90:171
errpar
function errpar(i)
Return error for parameter I.
Definition: millepede1.f90:1054
initun
subroutine initun(lun, cutfac)
Define unit for iterations (optional).
Definition: millepede1.f90:355
equloc
subroutine equloc(dergb, derlc, rrmeas, sigma)
Add single equation with its derivatives.
Definition: millepede1.f90:437
fitglo
subroutine fitglo(par)
Final global fit.
Definition: millepede1.f90:841
constf
subroutine constf(dercs, rhs)
Add constraint (optional).
Definition: millepede1.f90:398
corpar
function corpar(i, j)
Return correlation between parameters I and J.
Definition: millepede1.f90:1084
fitloc
subroutine fitloc
Fit after end of local block.
Definition: millepede1.f90:555
zerloc
subroutine zerloc(dergb, derlc)
Reset derivatives.
Definition: millepede1.f90:523
nonlin
subroutine nonlin(INDEX)
Set nonlinear flag for single parameter (optional).
Definition: millepede1.f90:328
parglo
subroutine parglo(par)
Initialize global parameters.
Definition: millepede1.f90:271
parsig
subroutine parsig(INDEX, sigma)
Define sigma for single parameter (optional).
Definition: millepede1.f90:300
prtglo
subroutine prtglo
Print final log file.
Definition: pede.f90:5417
Generated on Wed Sep 18 2024 14:36:52 for Millepede-II by doxygen 1.9.3