152 SUBROUTINE glk_initialize
164 CHARACTER*1 BBS1, BBS2
171 IF(init .NE. 0)
RETURN 229 LOGICAL FUNCTION glk_exist(id)
237 CALL glk_hadres(id,lact)
238 glk_exist = lact .NE. 0
243 DOUBLE PRECISION FUNCTION glk_hi(id,ib)
252 INTEGER ist,ist2,ist3,iflag2,ityphi,nch,idmem,lact
254 DATA idmem / -1256765/
256 IF(id .EQ. idmem)
goto 100
259 CALL glk_hadres(id,lact)
261 CALL glk_stop1(
' GLK_hi: nonexisting histo id=',id)
263 ist = m_index(lact,2)
267 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
268 ityphi = mod(iflag2,10)
269 IF(ityphi .NE. 1 .AND. ityphi.NE.3)
THEN 270 CALL glk_stop1(
' GLK_hi: 1-dim histos only !!! id=',id)
273 nch = nint(m_b(ist2+1))
277 ELSEIF(ib .GE. 1.and.ib .LE. nch)
THEN 279 glk_hi= m_b(ist +m_buf1+ib)
280 ELSEIF(ib .EQ. nch+1)
THEN 285 CALL glk_stop1(
' GLK_hi: wrong binning id=',id)
289 DOUBLE PRECISION FUNCTION glk_hie(id,ib)
297 INTEGER ist,ist2,ist3,iflag2,ityphi,nch,lact,ib,id
300 DATA idmem / -1256765/
302 IF(id .EQ. idmem)
goto 100
305 CALL glk_hadres(id,lact)
307 CALL glk_stop1(
' GLK_hie: nonexisting histo id=',id)
309 ist = m_index(lact,2)
313 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
314 ityphi = mod(iflag2,10)
315 IF(ityphi .NE. 1)
THEN 316 CALL glk_stop1(
' GLK_hie: 1-dim histos only !!! id=',id)
322 glk_hie= dsqrt( dabs(m_b(ist3 +4)))
323 ELSEIF(ib .GE. 1.and.ib .LE. nch)
THEN 325 glk_hie= dsqrt( dabs(m_b(ist+m_buf1+nch+ib)) )
326 ELSEIF(ib .EQ. nch+1)
THEN 328 glk_hie= dsqrt( dabs(m_b(ist3 +6)))
331 CALL glk_stop1(
'+++GLK_hie: wrong binning id= ',id)
335 SUBROUTINE glk_fil1(id,xx,wtx)
343 DOUBLE PRECISION xx,wtx
345 INTEGER ist,ist2,ist3,iflag2,ityphi,ipose1,iposx1,kposx1
346 DOUBLE PRECISION x1,wt1,xl,factx,xu
348 CALL glk_hadres(id,lact)
350 IF(lact .EQ. 0)
RETURN 351 ist = m_index(lact,2)
355 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
356 ityphi = mod(iflag2,10)
357 IF(ityphi .NE. 1)
CALL glk_stop1(
'+++GLK_Fil1: wrong id= ',id)
360 m_index(lact,3)=m_index(lact,3)+1
362 m_b(ist3 +7) =m_b(ist3 +7) +1
364 m_b(ist3 +8) =m_b(ist3 +8) +wt1
365 m_b(ist3 +9) =m_b(ist3 +9) +wt1*x1
376 ELSEIF(x1 .GT. xu)
THEN 386 kx = (x1-xl)*factx+1d0
387 kx = min( max(kx,1) ,nchx)
388 kposx1 = ist +m_buf1+kx
389 kpose1 = ist +m_buf1+nchx+kx
391 m_b(iposx1) = m_b(iposx1) +wt1
392 m_b(ipose1) = m_b(ipose1) +wt1*wt1
393 IF( kposx1 .NE. 0) m_b(kposx1) = m_b(kposx1) +wt1
394 IF( kposx1 .NE. 0) m_b(kpose1) = m_b(kpose1) +wt1*wt1
397 SUBROUTINE glk_fil1diff(id,xx,wtx,yy,wty)
408 DOUBLE PRECISION xx,wtx,yy,wty
410 DOUBLE PRECISION x1,x2,wt2,wt1,factx,xl,xu
411 INTEGER ist,ist2,ist3,iflag2,ityphi,kx,ke1,ie1,kx1,kx2,ke2
413 CALL glk_hadres(id,lact)
415 IF(lact .EQ. 0)
RETURN 416 ist = m_index(lact,2)
420 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
421 ityphi = mod(iflag2,10)
422 IF(ityphi .NE. 1)
THEN 423 CALL glk_stop1(
'GLK_Fil1diff: 1-dim histos only !!! id=',id)
429 m_index(lact,3)=m_index(lact,3)+1
431 m_b(ist3 +7) =m_b(ist3 +7) +1
433 m_b(ist3 +8) =m_b(ist3 +8) +wt1*x1 - wt2*x2
434 m_b(ist3 +9) =m_b(ist3 +9) +wt1*x1*x1 - wt2*x2*x2
445 ELSEIF(x1 .GT. xu)
THEN 452 kx = (x1-xl)*factx+1d0
453 kx = min( max(kx,1) ,nchx)
455 ke1 = ist +m_buf1+nchx+kx
462 ELSEIF(x2 .GT. xu)
THEN 469 kx = (x2-xl)*factx+1d0
470 kx = min( max(kx,1) ,nchx)
472 ke2 = ist +m_buf1+nchx+kx
475 IF( ix1 .EQ. ix2 )
THEN 476 m_b(ix1) = m_b(ix1) +wt1-wt2
477 m_b(ie1) = m_b(ie1) +(wt1-wt2)**2
479 m_b(ix1) = m_b(ix1) +wt1
480 m_b(ie1) = m_b(ie1) +wt1*wt1
481 m_b(ix2) = m_b(ix2) -wt2
482 m_b(ie2) = m_b(ie2) +wt2*wt2
484 IF( kx1 .EQ. kx2 )
THEN 486 m_b(kx1) = m_b(kx1) +wt1-wt2
487 m_b(ke1) = m_b(ke1) +(wt1-wt2)**2
491 m_b(kx1) = m_b(kx1) +wt1
492 m_b(ke1) = m_b(ke1) +wt1*wt1
495 m_b(kx2) = m_b(kx2) -wt2
496 m_b(ke2) = m_b(ke2) +wt2*wt2
501 SUBROUTINE glk_fil2(id,x,y,wtw)
508 DOUBLE PRECISION x,y,wtw
510 INTEGER ist,iflag2,ityphi,ist2,ist3,nchx,nchy,ly,ky,k2,kx
511 DOUBLE PRECISION xx,yy,wt,factx,xl,yl,facty
513 CALL glk_hadres(id,lact)
514 IF(lact .EQ. 0)
RETURN 515 ist = m_index(lact,2)
517 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
518 ityphi = mod(iflag2,10)
519 IF(ityphi .NE. 2)
THEN 520 CALL glk_stop1(
'GLK_Fil2: 2-dim histos only !!! id=',id)
528 m_index(lact,3)=m_index(lact,3)+1
536 IF(kx .GT. nchx) lx=3
540 IF(lx .EQ. 2) m_b(k) =m_b(k) +wt
541 k2 = ist+m_buf2 +nchx+kx
542 IF(lx .EQ. 2) m_b(k2) =m_b(k2) +wt**2
550 IF(ky .GT. nchy) ly=3
552 l = ist3 +lx +3*(ly-1)
555 k = ist+m_buf2 +kx +nchx*(ky-1)
556 IF(lx .EQ. 2.and.ly .EQ. 2) m_b(k)=m_b(k)+wt
559 SUBROUTINE glk_book1(id,title,nnchx,xxl,xxu)
564 DOUBLE PRECISION xxl,xxu
567 DOUBLE PRECISION xl,xu,ddx
568 INTEGER ist,nchx,ioplog,iopsla,ioperb,iflag2,ityphi,iflag1
569 INTEGER ist3,ist2,lengt2,lact,nnchx,iopsc2,iopsc1,j
573 IF(glk_exist(id))
goto 900
575 CALL glk_hadres(0,lact)
578 $
CALL glk_stop1(
'GLK_Book1: to many histos !!!!!, id= ',id)
580 m_index(lact,2)=m_length
583 CALL glk_copch(title,m_titlc(lact))
585 IF(nchx .GT. m_maxnb)
586 $
CALL glk_stop1(
' GLK_Book1: To many bins requested,id= ',id)
590 lengt2 = m_length +2*nchx +m_buf1+1
591 IF(lengt2 .GE. m_lenmb)
592 $
CALL glk_stop1(
'GLK_Book1:too litle storage, m_LenmB= ',m_lenmb)
594 DO j=m_length+1,lengt2+1
605 $ ioplog+10*iopsla+100*ioperb+1000*iopsc1+10000*iopsc2
620 m_b(ist +1) = 9999999999999d0
621 m_b(ist +2) = 9d12 + id*10 +9d0
622 m_b(ist +3) = 9d12 + iflag1*10 +9d0
623 m_b(ist +4) = 9d12 + iflag2*10 +9d0
635 IF(ddx .EQ. 0d0)
CALL glk_stop1(
'+++GLK_Book1: xl=xu, id= ',id)
636 m_b(ist2 +4) = dfloat(nchx)/ddx
645 900
CALL glk_retu1(
' WARNING GLK_Book1: already exists id= ', id)
648 SUBROUTINE glk_retu1(mesage,id)
657 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 658 WRITE(m_out,
'(a,a,i10,a)')
659 $
'++ ', mesage, id,
' ++' 661 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 663 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 664 WRITE(6 ,
'(a,a,i10,a)')
665 $
'++ ', mesage, id,
' ++' 667 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 670 SUBROUTINE glk_stop1(mesage,id)
679 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 680 WRITE(m_out,
'(a,a,i10,a)')
681 $
'++ ', mesage, id,
' ++' 683 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 685 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 686 WRITE(6 ,
'(a,a,i10,a)')
687 $
'++ ', mesage, id,
' ++' 689 $
'++++++++++++++++++++++++++++++++++++++++++++++++++++++' 694 SUBROUTINE glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
700 INTEGER id,ioplog,iopsla,ioperb,iopsc1,iopsc2
701 INTEGER ist,iflag1,lact
703 CALL glk_hadres(id,lact)
704 IF(lact .EQ. 0)
RETURN 707 iflag1 = nint(m_b(ist+3)-9d0-9d12)/10
708 ioplog = mod(iflag1,10)
709 iopsla = mod(iflag1,100)/10
710 ioperb = mod(iflag1,1000)/100
711 iopsc1 = mod(iflag1,10000)/1000
712 iopsc2 = mod(iflag1,100000)/10000
715 SUBROUTINE glk_idopt(id,ch)
722 INTEGER lact,ist,ioplog,ioperb,iopsla,iopsc1,iopsc2,iflag1
724 CALL glk_hadres(id,lact)
725 IF(lact .EQ. 0)
RETURN 728 CALL glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
729 IF(ch .EQ.
'LOGY' )
THEN 732 ELSEIF(ch .EQ.
'ERRO' )
THEN 735 ELSEIF(ch .EQ.
'SLAN' )
THEN 738 ELSEIF(ch .EQ.
'YMIN' )
THEN 740 ELSEIF(ch .EQ.
'YMAX' )
THEN 744 iflag1 = ioplog+10*iopsla+100*ioperb+1000*iopsc1+10000*iopsc2
745 m_b(ist+3) = 9d12 + iflag1*10 +9d0
749 SUBROUTINE glk_bookfun1(id,title,nchx,xmin,xmax,func)
756 DOUBLE PRECISION xmin,xmax,func
759 DOUBLE PRECISION yy(m_MaxNb)
763 DOUBLE PRECISION xl,xu,x
766 IF(glk_exist(id))
GOTO 900
769 CALL glk_book1(id,title,nchx,xl,xu)
771 CALL glk_idopt(id,
'SLAN')
772 IF(nchx .GT. 200)
goto 901
774 x= xmin +(xmax-xmin)/nchx*(ib-0.5d0)
779 900
CALL glk_retu1(
'+++GLK_BookFun1: already exists id=',id)
782 901
CALL glk_stop1(
'+++GLK_BookFun1: to many bins, id=',id)
785 SUBROUTINE glk_bookfun1i(id,title,nchx,xmin,xmax,func)
793 DOUBLE PRECISION xmin,xmax,func
796 DOUBLE PRECISION yy(m_MaxNb)
800 DOUBLE PRECISION xl,xu,x
801 DOUBLE PRECISION GLK_Gauss,a,b,Eeps,dx
804 IF(glk_exist(id))
GOTO 900
807 CALL glk_book1(id,title,nchx,xl,xu)
808 IF(nchx .GT. 200)
goto 901
810 dx = (xmax-xmin)/nchx
814 yy(ib) = glk_gauss(func,a,b,eeps)/dx
818 900
CALL glk_retu1(
'+++GLK_BookFun1I: already exists id=',id)
821 901
CALL glk_stop1(
'+++GLK_BookFun1I: to many bins, id=',id)
824 SUBROUTINE glk_bookfun1s(id,title,nchx,xmin,xmax,func)
831 DOUBLE PRECISION xmin,xmax,func
836 DOUBLE PRECISION yy(m_MaxNb),yy1(0:m_MaxNb)
838 DOUBLE PRECISION xl,xu,x3,x2,dx
842 IF( glk_exist(id) )
GOTO 900
845 CALL glk_book1(id,title,nchx,xl,xu)
848 CALL glk_idopt(id,
'SLAN')
849 IF(nchx.gt.200)
GOTO 901
855 x2= xmin +dx*(ib-0.5d0)
860 yy(ib) = ( yy1(ib-1) +4*yy(ib) +yy1(ib))/6d0
865 900
CALL glk_retu1(
'+++GLK_BookFun1S: already exists, id=',id)
868 901
CALL glk_stop1(
' +++GLK_BookFun1S: to many bins, id=',id)
871 DOUBLE PRECISION FUNCTION glk_gauss(f,a,b,Eeps)
883 DOUBLE PRECISION f,a,b,Eeps
885 DOUBLE PRECISION c1,c2,bb,s8,s16,y,aa,const,delta,eps,u
888 DOUBLE PRECISION w(12),x(12)
892 1/0.10122 85362 90376, 0.22238 10344 53374, 0.31370 66458 77887,
893 2 0.36268 37833 78362, 0.02715 24594 11754, 0.06225 35239 38648,
894 3 0.09515 85116 82493, 0.12462 89712 55534, 0.14959 59888 16577,
895 4 0.16915 65193 95003, 0.18260 34150 44924, 0.18945 06104 55069/
897 1/0.96028 98564 97536, 0.79666 64774 13627, 0.52553 24099 16329,
898 2 0.18343 46424 95650, 0.98940 09349 91650, 0.94457 50230 73233,
899 3 0.86563 12023 87832, 0.75540 44083 55003, 0.61787 62444 02644,
900 4 0.45801 67776 57227, 0.28160 35507 79259, 0.09501 25098 37637/
907 IF(abs(y) .LE. delta)
RETURN 915 1 s8=s8+w(i)*(f(c1+u)+f(c1-u))
918 3 s16=s16+w(i)*(f(c1+u)+f(c1-u))
921 IF(eeps .LT. 0d0)
THEN 922 IF(abs(s16-s8) .GT. eps*abs(s16))
GOTO 4
924 IF(abs(s16-s8) .GT. eps)
GOTO 4
926 glk_gauss=glk_gauss+s16
930 IF(abs(y) .GT. delta)
GOTO 2
934 7
FORMAT(1x,36hgaus ... too high accuracy required)
939 SUBROUTINE glk_book2(ID,TITLE,NCHX,XL,XU,NCHY,YL,YU)
944 DOUBLE PRECISION XL,XU,YL,YU
947 INTEGER ist,lact,lengt2,j,nnchx,nnchy
951 IF(glk_exist(id))
GOTO 900
953 CALL glk_hadres(0,lact)
954 IF(lact .EQ. 0)
GOTO 901
956 m_index(lact,2)=m_length
957 CALL glk_copch(title,m_titlc(lact))
960 lengt2 = m_length +44+nnchx*nnchy
961 IF(lengt2 .GE. m_lenmb)
GOTO 902
962 DO 10 j=m_length+1,lengt2+1
968 m_b(ist+4)=float(nnchx)/(m_b(ist+3)-m_b(ist+2))
972 m_b(ist+8)=float(nnchy)/(m_b(ist+7)-m_b(ist+6))
974 900
CALL glk_retu1(
'GLK_Book2: histo already exists!!!! id=',id)
976 901
CALL glk_stop1(
'GLK_Book2: too many histos !!!!! lact= ',lact)
978 902
CALL glk_stop1(
'GLK_Book2: too litle storage, m_LenmB=',m_lenmb)
982 SUBROUTINE glk_printall
991 IF(id .GT. 0)
CALL glk_print(id)
995 SUBROUTINE glk_listprint(mout)
1004 DOUBLE PRECISION xmin,xmax
1007 $
'============================================================================================' 1009 $
' ID TITLE nb, xmin, xmax' 1013 CALL glk_hinbo1(id,title,nb,xmin,xmax)
1014 WRITE(mout,
'(i8,a,a,i8,2g14.6)') id,
' ', title, nb,xmin,xmax
1021 SUBROUTINE glk_print(id)
1027 DOUBLE PRECISION xl,bind,xlow,z,er,avex,dx,fact,ovef,undf,bmax,bmin
1028 DOUBLE PRECISION sum,sumw,sumx
1029 INTEGER ist,ist2,ist3,idec,k2,k1,kros,j,ind,i,n,i1,ky,nchy
1030 INTEGER ioplog,iopsla,ioperb,iopsc1,iopsc2,lact,ker,ityphi
1032 CHARACTER*1 line(0:105),lchr(22),lb,lx,li,l0
1033 SAVE lb,lx,li,l0,lchr
1034 DATA lb,lx,li,l0 /
' ',
'X',
'I',
'0'/
1035 DATA lchr/
' ',
'1',
'2',
'3',
'4',
'5',
'6',
'7',
'8',
'9',
1036 $
'A',
'B',
'C',
'D',
'E',
'F',
'G',
'H',
'I',
'J',
'K',
'*'/
1038 CALL glk_hadres(id,lact)
1039 IF(lact .EQ. 0)
goto 900
1040 ist = m_index(lact,2)
1043 idec = nint(m_b(ist+2)-9d0-9d12)/10
1044 IF(idec .NE. id)
WRITE(6,*)
'++++GLK_PRINT: PANIC! ID,IDEC= ',id,idec
1045 CALL glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
1048 IF(ker .EQ. 1) lmx=54
1049 nent=m_index(lact,3)
1050 IF(nent .EQ. 0)
GOTO 901
1051 WRITE(m_out,1000) id,m_titlc(lact)
1052 1000
FORMAT(
'1',/,1x,i9,10x,a)
1055 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1056 ityphi = mod(iflag2,10)
1057 IF(ityphi .EQ. 2)
GOTO 200
1058 IF( (ityphi.NE.1) .AND. (ityphi.NE.3) )
1059 $
CALL glk_stop1(
' GLK_PRINT: wrong histo type, id=',id)
1063 dx = ( m_b(ist2 +3)-m_b(ist2 +2) )/float(nchx)
1067 bmax = m_b(istr)+1d-5*abs(m_b(istr))
1068 DO ibn=istr,istr+nchx-1
1069 bmax = max(bmax,m_b(ibn))
1070 bmin = min(bmin,m_b(ibn))
1072 IF(bmin .EQ. bmax)
GOTO 903
1073 IF(iopsc1 .EQ. 2) bmin=m_b(ist +5)
1074 IF(iopsc2 .EQ. 2) bmax=m_b(ist +6)
1077 IF(llg.and.bmin .LE. 0d0) bmin=bmax/10000.d0
1080 IF(deltb .EQ. 0d0)
GOTO 902
1081 fact = (lmx-1)/deltb
1082 kzer = -bmin*fact+1.00001d0
1083 IF(llg) fact=(lmx-1)/(log(bmax)-log(bmin))
1084 IF(llg) kzer=-log(bmin)*fact+1.00001d0
1091 IF(sumw .NE. 0d0) avex = sumx/sumw
1092 WRITE(m_out,
'(4a15 )')
'nent',
' sum',
'bmin',
'bmax' 1093 WRITE(m_out,
'(i15,3e15.5)') nent, sum, bmin, bmax
1094 WRITE(m_out,
'(4a15 )')
'undf',
'ovef',
'sumw',
'avex' 1095 WRITE(m_out,
'(4e15.5)') undf, ovef, sumw, avex
1097 IF(llg)
write(m_out,1105)
1098 1105
format(35x,17hlogarithmic scale)
1112 bind= max(bind,bmin)
1113 bind= min(bind,bmax)
1114 kros=(bind-bmin)*fact+1.0001d0
1115 IF(llg) kros=log(bind/bmin)*fact+1.0001d0
1117 k2=min0(lmx,max0(1,k2))
1119 k1=min0(lmx,max0(1,k1))
1125 WRITE(m_out,
'(a, f7.4, a, d14.6, 132a1)')
1126 $
' ', xlow,
' ', z,
' ',(line(i),i=1,lmx)
1128 er=dsqrt(dabs(m_b(ind+nchx)))
1129 WRITE(m_out,
'(a,f7.4, a,d14.6, a,d14.6, 132a1 )')
1130 $
' ',xlow,
' ', z,
' ', er,
' ',(line(i),i=1,lmx)
1141 WRITE(m_out,2000) (lx,i=1,nchy)
1142 2000
format(1h ,10x,2hxx,100a1)
1145 k=ist +m_buf2 +kx+nchx*(ky-1)
1149 IF(dabs(m_b(k)) .LT. 1d-20) n=1
1154 WRITE(m_out,2100) (line(i),i=1,i1)
1155 2100
format(1h ,10x,1hx,100a1)
1157 WRITE(m_out,2000) (lx,i=1,nchy)
1159 900
CALL glk_retu1(
'GLK_PRINT: nonexisting histo',id)
1161 901
CALL glk_retu1(.eq.
' GLK_PRINT: nent0',id)
1163 902
CALL glk_retu1(
' GLK_PRINT: wrong plotting limits, id=',id)
1165 903
CALL glk_retu1(.eq.
' GLK_PRINT: bminbmax, id=',id)
1168 SUBROUTINE glk_operat(ida,chr,idb,idc,coef1,coef2)
1173 DOUBLE PRECISION coef1,coef2
1177 DOUBLE PRECISION xl,xu
1178 INTEGER ista,ista2,ista3,ncha,iflag2a,ityphia,lactb
1179 INTEGER k,j,nchc,istc2,istc3,i1,j2,j3,j1,i2,i3,istc,istb2
1180 INTEGER lacta,id,istb,nchx,iflag2b,ityphib,lactc
1182 CALL glk_hadres(ida,lacta)
1183 IF(lacta .EQ. 0)
RETURN 1184 ista = m_index(lacta,2)
1189 iflag2a = nint(m_b(ista+4)-9d0-9d12)/10
1190 ityphia = mod(iflag2a,10)
1191 IF(ityphia .NE. 1)
CALL glk_stop1(
'GLK_Operat: 1-dim histos only, id=' 1193 CALL glk_hadres(idb,lactb)
1194 IF(lactb .EQ. 0)
RETURN 1195 istb = m_index(lactb,2)
1199 IF(nchb .NE. ncha)
goto 900
1201 iflag2b = nint(m_b(istb+4)-9d0-9d12)/10
1202 ityphib = mod(iflag2b,10)
1203 IF(ityphib .NE. 1)
CALL glk_stop1(
'GLK_Operat: 1-dim histos only, id=' 1205 CALL glk_hadres(idc,lactc)
1206 IF(lactc .EQ. 0)
THEN 1208 CALL glk_hinbo1(ida,title,nchx,xl,xu)
1209 CALL glk_book1(idc,title,nchx,xl,xu)
1210 CALL glk_hadres(idc,lactc)
1211 istc = m_index(lactc,2)
1213 m_b(istc+ 3)= m_b(ista +3)
1216 m_index(lactc,3) = 1
1218 istc = m_index(lactc,2)
1223 IF(nchc .NE. ncha)
goto 900
1224 IF(ncha .NE. nchb .OR. nchb .NE. nchc)
GOTO 900
1226 IF(k .GT. ncha)
THEN 1237 i1 = ista +m_buf1 +k
1238 i2 = istb +m_buf1 +k
1239 i3 = istc +m_buf1 +k
1240 j1 = ista +m_buf1 +ncha+k
1241 j2 = istb +m_buf1 +ncha+k
1242 j3 = istc +m_buf1 +ncha+k
1244 IF (chr .EQ.
'+')
THEN 1245 m_b(i3) = coef1*m_b(i1) + coef2*m_b(i2)
1246 m_b(j3) = coef1**2*m_b(j1) + coef2**2*m_b(j2)
1247 ELSEIF(chr .EQ.
'-')
THEN 1248 m_b(i3) = coef1*m_b(i1) - coef2*m_b(i2)
1249 m_b(j3) = coef1**2*m_b(j1) + coef2**2*m_b(j2)
1250 ELSEIF(chr .EQ.
'*')
THEN 1251 m_b(j3) = (coef1*coef2)**2
1252 $ *(m_b(j1)*m_b(i2)**2 + m_b(j2)*m_b(i1)**2)
1253 m_b(i3) = coef1*m_b(i1) * coef2*m_b(i2)
1254 ELSEIF(chr .EQ.
'/')
THEN 1255 IF(m_b(i2) .EQ. 0d0)
THEN 1261 m_b(j3) = (coef1/coef2)**2 *m_b(j1) /m_b(i2)**2
1262 $ +(coef1/coef2)**2 *m_b(j2) *(m_b(i1)/m_b(i2)**2)
1270 900
WRITE(m_out,*)
'+++++ GLK_Operat: non-equal no. bins ',ida,idb,idc
1271 WRITE( 6,*)
'+++++ GLK_Operat: non-equal no. bins ',ida,idb,idc
1273 901
WRITE(m_out,*)
'+++++ GLK_Operat: wrong chr=',chr
1274 WRITE( 6,*)
'+++++ GLK_Operat: wrong chr=',chr
1278 SUBROUTINE glk_hinbo1(id,title,nchx,xl,xu)
1283 DOUBLE PRECISION xl,xu
1285 INTEGER lact,ist,ist2
1287 CALL glk_hadres(id,lact)
1288 IF(lact .EQ. 0)
THEN 1289 CALL glk_stop1(
'+++STOP in GLK_hinbo1: wrong id=',id)
1296 title = m_titlc(lact)
1299 SUBROUTINE glk_unpak(id,a,chd1,idum)
1307 DOUBLE PRECISION a(*)
1310 INTEGER lact,ist,ist2,iflag2,ityphi,local,nch,nchy,ib
1312 CALL glk_hadres(id,lact)
1313 IF(lact .EQ. 0)
goto 900
1314 ist = m_index(lact,2)
1316 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1317 ityphi = mod(iflag2,10)
1318 IF(ityphi .EQ. 1)
THEN 1321 ELSEIF(ityphi .EQ. 2)
THEN 1326 CALL glk_stop1(
'+++GLK_UnPak: check type of histo id=',id)
1329 IF(chd1 .NE.
'ERRO')
THEN 1331 a(ib) = m_b(local+ib)
1334 IF(ityphi .EQ. 2)
goto 901
1335 a(ib) = dsqrt( dabs(m_b(local+nch+ib) ))
1339 900
CALL glk_retu1(
'+++GLK_UnPak: nonexisting id=',id)
1341 901
CALL glk_retu1(
'+++GLK_UnPak: no errors, two-dim, id=',id)
1344 SUBROUTINE glk_pak(id,a)
1351 DOUBLE PRECISION a(*)
1353 INTEGER lact,ist,ist2,iflag2,ityphi,nch,local,ib,nchy
1355 CALL glk_hadres(id,lact)
1356 IF(lact .EQ. 0)
goto 900
1357 ist = m_index(lact,2)
1360 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1361 ityphi = mod(iflag2,10)
1362 IF(ityphi .EQ. 1)
THEN 1365 ELSEIF(ityphi .EQ. 2)
THEN 1370 CALL glk_stop1(
'+++GLK_Pak: wrong histo type, id=',id)
1373 m_b(local +ib) = a(ib)
1379 CALL glk_stop1(
'+++GLK_Pak: nonexisting id=',id)
1382 SUBROUTINE glk_pake(id,a)
1389 DOUBLE PRECISION a(*)
1391 INTEGER lact,ist,ist2,nch,iflag2,ityphi
1394 CALL glk_hadres(id,lact)
1395 IF(lact .EQ. 0)
goto 901
1396 ist = m_index(lact,2)
1400 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1401 ityphi = mod(iflag2,10)
1402 IF(ityphi .NE. 1)
GOTO 900
1404 m_b(ist+m_buf1+nch+ib) = a(ib)**2
1406 CALL glk_idopt( id,
'ERRO')
1408 900
CALL glk_stop1(
'+++GLK_Pake: only for 1-dim hist, id=',id)
1410 901
CALL glk_stop1(
'+++GLK_Pake: nonexisting id=',id)
1414 SUBROUTINE glk_range1(id,ylr,yur)
1421 DOUBLE PRECISION ylr,yur
1423 INTEGER lact,ist,ist2,nch,ib,ioplog,iopsla,ioperb,iopsc1
1424 DOUBLE PRECISION yl,yu
1426 CALL glk_hadres(id,lact)
1427 IF(lact .EQ. 0)
RETURN 1428 ist = m_index(lact,2)
1431 yl = m_b(ist+m_buf1+1)
1432 yu = m_b(ist+m_buf1+1)
1434 yl = min(yl,m_b(ist+m_buf1+ib))
1435 yu = max(yu,m_b(ist+m_buf1+ib))
1438 yu = yu + 0.05*abs(yu-yl)
1442 CALL glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
1443 IF(iopsc1 .EQ. 2) yl= m_b( ist +5)
1444 IF(iopsc2 .EQ. 2) yu= m_b( ist +6)
1450 SUBROUTINE glk_hinbo2(id,nchx,xl,xu,nchy,yl,yu)
1454 INTEGER id,nchx,nchy
1455 DOUBLE PRECISION xl,xu,yl,yu
1456 INTEGER lact,ist,ist2
1458 CALL glk_hadres(id,lact)
1459 IF(lact .EQ. 0)
goto 900
1460 ist = m_index(lact,2)
1469 900
CALL glk_stop1(
' +++GLK_hinbo2: nonexisting histo id= ',id)
1473 SUBROUTINE glk_ymaxim(id,wmax)
1478 DOUBLE PRECISION wmax
1479 INTEGER lact,ist,jd,k
1482 CALL glk_hadres(id,lact)
1483 IF(lact .EQ. 0)
RETURN 1484 ist= m_index(lact,2)
1486 CALL glk_idopt(id,
'YMAX')
1489 IF(m_index(k,1) .EQ. 0)
GOTO 20
1493 CALL glk_idopt(jd,
'YMAX')
1499 SUBROUTINE glk_yminim(id,wmin)
1504 DOUBLE PRECISION wmin
1505 INTEGER lact,ist,k,jd
1508 CALL glk_hadres(id,lact)
1509 IF(lact .EQ. 0)
RETURN 1510 ist =m_index(lact,2)
1512 CALL glk_idopt(id,
'YMIN')
1515 IF(m_index(k,1) .EQ. 0)
GOTO 20
1519 CALL glk_idopt(jd,
'YMIN')
1525 SUBROUTINE glk_reset(id,chd1)
1531 INTEGER lact,ist,ist2,iflag2,ityphi,ist3,nchx,nch,local,nchy,j
1533 CALL glk_hadres(id,lact)
1534 IF(lact .LE. 0)
RETURN 1535 ist =m_index(lact,2)
1538 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1539 ityphi = mod(iflag2,10)
1540 IF(ityphi .EQ. 1)
THEN 1545 local = ist + m_buf1
1546 ELSEIF(ityphi .EQ. 2)
THEN 1554 CALL glk_stop1(
'+++GLK_Reset: wrong type id=',id)
1557 DO j=ist3+1,local +nch
1564 SUBROUTINE glk_delet(id1)
1574 INTEGER id,lact,ist,ist2,nch,iflag2,ityphi,local,k,i,l,next
1577 IF(id .EQ. 0)
GOTO 300
1578 IF( .NOT. glk_exist(id))
GOTO 900
1579 CALL glk_hadres(id,lact)
1580 ist = m_index(lact,2)
1584 idec = nint(m_b(ist+2)-9d0-9d12)/10
1585 IF(idec .NE. id)
WRITE(6,*)
1586 $
'++++GLK_DELET: ALARM! ID,IDEC= ',id,idec
1589 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
1590 ityphi = mod(iflag2,10)
1591 IF(ityphi .EQ. 1)
THEN 1596 local = nch+m_buf1+1
1597 ELSEIF(ityphi .EQ. 2)
THEN 1603 local = nch+m_buf2+1
1605 CALL glk_stop1(
'+++GLK_Delet: wrong type id=',id)
1610 DO 15 k =next,m_length
1614 m_length=m_length-local
1616 DO 20 k=m_length+1, m_length+local
1619 DO 25 l=lact+1,m_idmax
1620 IF(m_index(l,1) .NE. 0) m_index(l,2)=m_index(l,2)-local
1623 DO 30 l=lact+1,m_idmax
1624 m_index(l-1,1)=m_index(l,1)
1625 m_index(l-1,2)=m_index(l,2)
1626 m_index(l-1,3)=m_index(l,3)
1627 m_titlc(l-1)=m_titlc(l)
1630 m_index(m_idmax,1)=0
1631 m_index(m_idmax,2)=0
1632 m_index(m_idmax,3)=0
1634 50 m_titlc(m_idmax)(k:k)=
' ' 1643 350 m_titlc(i)(k:k)=
' ' 1648 CALL glk_retu1(
' +++GLK_DELET: nonexisting histo id= ',id)
1652 SUBROUTINE glk_copch(ch1,ch2)
1656 CHARACTER*80 ch1,ch2
1662 IF( ch1(i:i) .EQ.
'$' .or. met )
THEN 1671 INTEGER FUNCTION glk_jadre2(id)
1682 IF(m_index(i,1) .EQ. id)
goto 2
1690 SUBROUTINE glk_hadres(id1,jadres)
1704 INTEGER iguess,jdlast,idlast
1705 DATA iguess,jdlast,idlast /-2141593,-3141593,-3141593/
1706 SAVE iguess,jdlast,idlast
1713 IF(m_index(i,1) .EQ. 0)
GOTO 44
1715 CALL glk_stop1(
'+++GLK_hadres: Too short m_index=',m_index)
1722 IF(jdlast .EQ. -3141593)
GOTO 10
1723 IF(iguess .EQ. -2141593)
GOTO 10
1724 IF(iguess .EQ. 0)
GOTO 10
1725 IF(jdlast .EQ. 0)
GOTO 10
1728 IF(jdlast .LT. 1 .OR. jdlast .GT. m_idmax)
THEN 1729 WRITE(6,*)
'+++++ hadres: jdlast=',jdlast
1731 IF(m_index(jdlast,1) .EQ. id)
THEN 1739 IF(iguess .LT. 1 .OR. iguess .GT. m_idmax)
THEN 1740 WRITE(6,*)
'+++++ hadres: iguess=',iguess
1742 IF(m_index(iguess,1) .EQ. id)
THEN 1756 IF(m_index(i,1) .EQ. id)
GOTO 20
1770 IF(m_index(i,1) .EQ. 0)
GOTO 40
1771 IF(m_index(i,1) .EQ. idlast)
THEN 1773 IF(ist .GT. 0 .AND. ist .LT. m_lenmb) m_b(ist +7) = jadres
1780 iguess = m_b( m_index(jadres,2) +7)
1790 SUBROUTINE glk_readfile(Dname)
1800 WRITE( *,*)
'GLK_ReadFile: Reading histos from ', dname
1801 WRITE(m_out,*)
'GLK_ReadFile: Reading histos from ', dname
1803 OPEN(ninph,file=dname)
1804 CALL glk_hrfile(ninph,
' ',
' ')
1805 CALL glk_hrin(0,0,0)
1809 SUBROUTINE glk_writefile(Dname)
1819 WRITE( *,*)
'GLK_WriteFile: Writing histos into ', dname
1820 WRITE(m_out,*)
'GLK_WriteFile: Writing histos into ', dname
1822 OPEN(nouth,file=dname)
1823 CALL glk_hrfile(nouth,
' ',
' ')
1824 CALL glk_hrout(0,0,
' ')
1828 SUBROUTINE glk_hrfile(nhruni,chd1,chd2)
1831 CHARACTER*(*) chd1,chd2
1840 SUBROUTINE glk_hrout(idum1,idum2,chdum)
1847 INTEGER i,k,last,idum1,idum2
1850 CALL glk_hadres(0,last)
1851 IF(last.EQ.0)
GOTO 900
1853 WRITE(m_huni,
'(6i10)') m_version, m_lenind, m_lenmb, m_length
1854 WRITE(m_huni,
'(6i10)') ((m_index(i,k),k=1,3),i=1,m_lenind)
1855 WRITE(m_huni,
'(a80)') (m_titlc(i), i=1,m_lenind)
1856 WRITE(m_huni,
'(3d24.16)') (m_b(i), i=1,m_length)
1859 WRITE(m_out,*)
'+++ GLK_hrout: no space in index' 1860 WRITE( *,*)
'+++ GLK_hrout: no space in index' 1864 SUBROUTINE glk_hrin(idum1,idum2,idum3)
1874 INTEGER idum1,idum2,idum3
1875 INTEGER l,lact,lenold,istn,idn,k,lenind3,nvrs3,nouth
1876 INTEGER i,lengt3,lenma3
1878 INTEGER lndex(m_idmax,3)
1879 CHARACTER*80 titld(m_idmax)
1885 READ(nouth,
'(6i10)') nvrs3,lenind3,lenma3,lengt3
1886 IF(m_length+lengt3 .GE. m_lenmb)
GOTO 900
1888 IF(m_version .NE. nvrs3)
WRITE(m_out,*)
1889 $
'+++++WARNING (GLK_hrin): histos produced by older version',nvrs3
1890 IF(m_version .NE. nvrs3)
WRITE(6,*)
1891 $
'+++++WARNING (GLK_hrin): histos produced by older version',nvrs3
1898 IF(nvrs3. lt. 130) lenind3 = m_idmax
1900 READ(nouth,
'(6i10)') ((lndex(i,k),k=1,3),i=1,lenind3)
1901 READ(nouth,
'(a80)') (titld(i), i=1,lenind3)
1904 m_length=m_length+lengt3
1905 READ(nouth,
'(3d24.16)') (m_b(i),i=lenold+1,m_length)
1908 CALL glk_hadres(0,lact)
1910 IF(lact .EQ. 0)
GOTO 901
1912 IF(idn .EQ. 0)
GOTO 100
1915 IF( glk_exist(idn) )
THEN 1916 idn = idn +1000000*(idn/iabs(idn))
1920 m_index(lact,2)=lndex(l,2)+lenold
1921 m_index(lact,3)=lndex(l,3)
1922 m_titlc(lact) =titld(l)
1924 istn = m_index(lact,2)
1925 m_b(istn +2) = 9d12 + idn*10 +9d0
1932 CALL glk_stop1(
'++++ GLK_hrin: to litle space, m_LenmB= ',m_lenmb)
1934 CALL glk_stop1(
'++++ GLK_hrin: to many histos, m_idmax= ',m_idmax)
1938 SUBROUTINE glk_hrin2(idum1,idum2,idum3)
1946 INTEGER idum1,idum2,idum3
1948 DOUBLE PRECISION bz(m_LenmB)
1949 INTEGER indez(m_idmax,3)
1950 CHARACTER*80 titlz(m_idmax)
1952 INTEGER nouth,ist3,nchx,ist,ist2,ist3z,nchxz,istz
1953 INTEGER ist2z,lact,lenmaz,lengtz,nvrsz,lenindz,lz,id,i,k
1958 READ(nouth,
'(6i10)') nvrsz,lenindz,lenmaz,lengtz
1960 IF(m_version .NE. nvrsz)
WRITE(m_out,*)
1961 $
'++++WARNING (GLK_hrin2): histos produced by older version',nvrsz
1962 IF(m_version .NE. nvrsz)
WRITE(6,*)
1963 $
'++++WARNING (GLK_hrin2): histos produced by older version',nvrsz
1966 IF(nvrsz. lt. 130) lenindz = m_idmax
1973 READ(nouth,
'(6i10)') ((indez(i,k),k=1,3),i=1,lenindz)
1974 READ(nouth,
'(a80)') (titlz(i) , i=1,lenindz)
1975 READ(nouth,
'(3d24.16)') (bz(i),i=1,lengtz)
1980 IF(id .EQ. 0)
GOTO 200
1981 IF( .NOT. glk_exist(id))
THEN 1982 CALL glk_retu1(
'GLK_hrin2: unmached skipped histo ID=', id)
1986 CALL glk_hadres(id,lact)
1987 ist = m_index(lact,2)
1995 nchxz = bz(ist2z +1)
1996 IF(nchx .NE. nchxz)
THEN 1997 CALL glk_retu1(
'GLK_hrin2: non-equal bins, skipped ID=', id)
2002 m_index(lact,3) = m_index(lact,3)+indez(lact,3)
2005 m_b(ist3+i)=m_b(ist3+i) +bz(ist3z+i)
2008 m_b(ist3+13)=max(m_b(ist3+13),m_b(ist3z+13))
2011 m_b(ist+m_buf1+i)=m_b(ist+m_buf1+i) +bz(istz+m_buf1+i)
2018 SUBROUTINE glk_hrend(chdum)
2036 SUBROUTINE glk_plinitialize(Lint,TeXfile)
2051 CHARACTER*60 TeXfile
2054 CALL glk_plint(lint)
2056 OPEN(noufig,file=texfile)
2057 CALL glk_plcap(noufig)
2060 SUBROUTINE glk_plend
2068 IF( abs(m_lint) .NE. 1)
THEN 2069 WRITE(m_ltx,
'(2A)') m_bs,
'end{document}' 2074 SUBROUTINE glk_plint(Lint)
2084 SUBROUTINE glk_plcap(LtxUnit)
2101 IF( abs(m_lint) .EQ. 0)
THEN 2103 WRITE(m_ltx,
'(A,A)') m_bs,
'documentclass[12pt]{article}' 2105 WRITE(m_ltx,
'(A,A)') m_bs,
'textwidth = 16cm' 2106 WRITE(m_ltx,
'(A,A)') m_bs,
'textheight = 18cm' 2107 WRITE(m_ltx,
'(A,A)') m_bs,
'begin{document}' 2108 WRITE(m_ltx,
'(A)')
' ' 2109 ELSEIF( abs(m_lint) .EQ. 1)
THEN 2111 WRITE(m_ltx,
'(A)')
' ' 2112 ELSEIF( abs(m_lint) .EQ. 2)
THEN 2116 WRITE(m_ltx,
'(A,A)') m_bs,
'documentclass[12pt,dvips]{article}' 2117 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{amsmath}' 2118 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{amssymb}' 2120 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{epsfig}' 2121 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{epic}' 2122 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{eepic}' 2123 WRITE(m_ltx,
'(A,A)') m_bs,
'usepackage{color}' 2132 WRITE(m_ltx,
'(A,A)') m_bs,
'begin{document}' 2133 WRITE(m_ltx,
'(A,A)') m_bs,
'pagestyle{empty}' 2134 WRITE(m_ltx,
'(A)')
' ' 2136 CALL glk_stop1(
'+++STOP in GLK_PlInt, wrong m_lint=',m_lint)
2141 SUBROUTINE glk_plot(id,ch1,ch2,kdum)
2145 CHARACTER CH1,CH2,CHR
2148 DOUBLE PRECISION YY(m_MaxNb),YER(m_MaxNb)
2150 INTEGER idum,kax,kay,ioplog,iopsla,ioperb,iopsc1,iopsc2
2152 DOUBLE PRECISION XL,XU,DXL,DXU,yl,yu
2156 IF(.NOT.glk_exist(id))
GOTO 900
2158 CALL glk_unpak(id,yy ,
' ',idum)
2159 CALL glk_unpak(id,yer,
'ERRO',idum)
2160 CALL glk_hinbo1(id,title,nchx,dxl,dxu)
2163 CALL glk_range1(id,yl,yu)
2166 IF(ch1 .EQ.
'S')
THEN 2173 CALL glk_plfram1(id,kax,kay)
2175 WRITE(m_ltx,
'(A)')
'%========== next plot (line) ==========' 2176 WRITE(m_ltx,
'(A,I10)')
'%==== HISTOGRAM ID=',id
2177 WRITE(m_ltx,
'(A,A70 )')
'% ',title
2179 CALL glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
2181 IF (iopsla .EQ. 2) chr=
'C' 2183 IF (ch2 .EQ.
'B') chr=
' ' 2184 IF (ch2 .EQ.
'*') chr=
'*' 2185 IF (ch2 .EQ.
'C') chr=
'C' 2187 IF (chr .EQ.
' ')
THEN 2189 CALL glk_plhist(kax,kay,nchx,yl,yu,yy,ker,yer)
2190 ELSE IF(chr .EQ.
'*')
THEN 2192 CALL glk_plhis2(kax,kay,nchx,yl,yu,yy,ker,yer)
2193 ELSE IF(chr .EQ.
'C')
THEN 2195 CALL glk_plcirc(kax,kay,nchx,yl,yu,yy)
2200 WRITE(m_ltx,
'(2A)') m_bs,
'end{picture} % close entire picture ' 2201 WRITE(m_ltx,
'(2A)') m_bs,
'end{figure}' 2204 900
CALL glk_retu1(
'+++GLK_PLOT: Nonexistig histo, skipped, id=' ,id)
2207 SUBROUTINE glk_plfram1(ID,kax,kay)
2213 DOUBLE PRECISION TIPSY(20),TIPSX(20)
2214 DOUBLE PRECISION XL,DXL,XU,DXU
2215 INTEGER ntipy,ntipx,nchx,icont
2216 DOUBLE PRECISION yu,yl
2220 CALL glk_hinbo1(id,title,nchx,dxl,dxu)
2223 CALL glk_range1(id,yl,yu)
2225 IF(icont .GT. 1)
WRITE(m_ltx,
'(2A)') m_bs,
'newpage' 2229 WRITE(m_ltx,
'(A)')
' ' 2230 WRITE(m_ltx,
'(A)')
' ' 2231 WRITE(m_ltx,
'(A)')
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2232 $%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' 2233 WRITE(m_ltx,
'(A)')
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2234 $%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' 2235 WRITE(m_ltx,
'(2A)') m_bs,
'begin{figure}[!ht]' 2236 WRITE(m_ltx,
'(2A)') m_bs,
'centering' 2240 WRITE(m_ltx,
'(4A)') m_bs,
'caption{',m_bs,
'small' 2241 IF(m_keytit.EQ.0)
THEN 2242 WRITE(m_ltx,
'(A)') title
2244 WRITE(m_ltx,
'(A)') m_titch(1)
2246 WRITE(m_ltx,
'(A)')
'}' 2250 WRITE(m_ltx,
'(A)')
'% =========== big frame, title etc. =======' 2251 WRITE(m_ltx,
'(4A)') m_bs,
'setlength{',m_bs,
'unitlength}{0.1mm}' 2252 WRITE(m_ltx,
'(2A)') m_bs,
'begin{picture}(1600,1500)' 2254 $ m_bs,
'put(0,0){',m_bs,
'framebox(1600,1500){ }}' 2255 WRITE(m_ltx,
'(A)')
'% =========== small frame, labeled axis ===' 2256 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2257 $ m_bs,
'put(300,250){',m_bs,
'begin{picture}( ',kax,
',',kay,
')' 2258 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2259 $ m_bs,
'put(0,0){',m_bs,
'framebox( ',kax,
',',kay,
'){ }}' 2260 WRITE(m_ltx,
'(A)')
'% =========== x and y axis ================' 2261 CALL glk_saxisx(kax,xl,xu,ntipx,tipsx)
2262 CALL glk_saxisy(kay,yl,yu,ntipy,tipsy)
2263 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}' 2264 $ ,
'% end of plotting labeled axis' 2267 SUBROUTINE glk_saxisx(kay,YL,YU,NLT,TIPSY)
2273 DOUBLE PRECISION YL,YU,TIPSY(20)
2275 INTEGER LY,JY,n,nts,k,lex
2276 DOUBLE PRECISION DY,pds,scmx,p0s,ddys,yy0l,ddyl,pdl,p0l,yy0s
2279 ly = nint( log10(dy) -0.4999999d0 )
2280 jy = nint(dy/10d0**ly)
2281 ddyl = dy*10d0**(-ly)
2282 IF( jy .EQ. 1) ddyl = 10d0**ly*0.25d0
2283 IF( jy .GE. 2.AND.jy .LE. 3) ddyl = 10d0**ly*0.5d0
2284 IF( jy .GE. 4.AND.jy .LE. 6) ddyl = 10d0**ly*1.0d0
2285 IF( jy .GE. 7) ddyl = 10d0**ly*2.0d0
2286 WRITE(m_ltx,
'(A)')
'% .......GLK_SAxisX........ ' 2287 WRITE(m_ltx,
'(A,I4)')
'% JY= ',jy
2290 nlt = max0(min0(nlt,20),1)+1
2291 yy0l = nint(yl/ddyl+0.5d0)*ddyl
2293 yy0s = nint(yl/ddys+0.4999999d0)*ddys
2294 p0l = kay*(yy0l-yl)/(yu-yl)
2295 pdl = kay*ddyl/(yu-yl)
2296 p0s = kay*(yy0s-yl)/(yu-yl)
2297 pds = kay*ddys/(yu-yl)
2298 nlt = int(abs(yu-yy0l)/ddyl+0.0000001d0)+1
2299 nts = int(abs(yu-yy0s)/ddys+0.0000001d0)+1
2301 tipsy(n) =yy0l+ ddyl*(n-1)
2304 $ m_bs,
'multiput(' ,p0l,
',0)(' ,pdl,
',0){' ,nlt,
'}{',
2305 $ m_bs,
'line(0,1){25}}',
2306 $ m_bs,
'multiput(' ,p0s,
',0)(' ,pds,
',0){' ,nts,
'}{',
2307 $ m_bs,
'line(0,1){10}}' 2309 $ m_bs,
'multiput(' ,p0l,
',' ,kay,
')(' ,pdl,
',0){' ,nlt,
2310 $
'}{' ,m_bs,
'line(0,-1){25}}',
2311 $ m_bs,
'multiput(' ,p0s,
',' ,kay,
')(' ,pds,
',0){' ,nts,
2312 $
'}{' ,m_bs,
'line(0,-1){10}}' 2313 1000
FORMAT(2a,f8.2,a,f8.2,a,i4,3a)
2314 1001
FORMAT(2a,f8.2,a,i4,a,f8.2,a,i4,3a)
2316 scmx = dmax1(dabs(yl),dabs(yu))
2317 lex = nint( log10(scmx) -0.50001)
2319 k = nint(kay*(tipsy(n)-yl)/(yu-yl))
2320 IF(lex .LT. 2.AND.lex .GT. -1)
THEN 2322 WRITE(m_ltx,
'(2A,I4,5A,F8.3,A)')
2323 $ m_bs,
'put(',k,
',-25){',m_bs,
'makebox(0,0)[t]{',m_bs,
'large $ ',
2327 WRITE(m_ltx,
'(2A,I4,5A,F8.3,2A,I4,A)')
2328 $ m_bs,
'put(' ,k,
',-25){',m_bs,
'makebox(0,0)[t]{',m_bs,
'large $ ',
2329 $ tipsy(n)/(10d0**lex),m_bs,
'cdot 10^{',lex,
'} $}}' 2334 SUBROUTINE glk_saxisy(kay,yl,yu,nlt,tipsy)
2340 DOUBLE PRECISION yl,yu,tipsy(20)
2342 DOUBLE PRECISION dy,ddyl,z0l,scmx,yy0s,ddys,yy0l,p0l,pds,p0s,pdl
2343 INTEGER ly,jy,n,nts,k,lex
2346 ly = nint( log10(dy) -0.49999999d0 )
2347 jy = nint(dy/10d0**ly)
2348 ddyl = dy*10d0**(-ly)
2349 IF( jy .EQ. 1) ddyl = 10d0**ly*0.25d0
2350 IF( jy .GE. 2.AND.jy .LE. 3) ddyl = 10d0**ly*0.5d0
2351 IF( jy .GE. 4.AND.jy .LE. 6) ddyl = 10d0**ly*1.0d0
2352 IF( jy .GE. 7) ddyl = 10d0**ly*2.0d0
2353 WRITE(m_ltx,
'(A)')
'% .......GLK_SAxisY........ ' 2354 WRITE(m_ltx,
'(A,I4)')
'% JY= ',jy
2357 nlt = max0(min0(nlt,20),1)+1
2358 yy0l = nint(yl/ddyl+0.4999999d0)*ddyl
2360 yy0s = nint(yl/ddys+0.5d0)*ddys
2361 p0l = kay*(yy0l-yl)/(yu-yl)
2362 pdl = kay*ddyl/(yu-yl)
2363 p0s = kay*(yy0s-yl)/(yu-yl)
2364 pds = kay*ddys/(yu-yl)
2365 nlt= int(abs(yu-yy0l)/ddyl+0.0000001d0) +1
2366 nts= int(abs(yu-yy0s)/ddys+0.0000001d0) +1
2368 tipsy(n) =yy0l+ ddyl*(n-1)
2372 $ m_bs,
'multiput(0,' ,p0l,
')(0,' ,pdl ,
'){' ,nlt,
'}{',
2373 $ m_bs,
'line(1,0){25}}',
2374 $ m_bs,
'multiput(0,' ,p0s,
')(0,' ,pds,
'){' ,nts,
'}{',
2375 $ m_bs,
'line(1,0){10}}' 2377 $ m_bs,
'multiput(' ,kay,
',' ,p0l,
')(0,' ,pdl,
'){' ,nlt,
2378 $
'}{',m_bs,
'line(-1,0){25}}',
2379 $ m_bs,
'multiput(' ,kay,
',' ,p0s,
')(0,' ,pds,
'){' ,nts,
2380 $
'}{',m_bs,
'line(-1,0){10}}' 2381 1000
FORMAT(2a,f8.2,a,f8.2,a,i4,3a)
2382 1001
FORMAT(2a,i4,a,f8.2,a,f8.2,a,i4,3a)
2384 z0l = kay*(-yl)/(yu-yl)
2385 IF(z0l .GT. 0d0.AND.z0l .LT. float(kay))
2386 $
WRITE(m_ltx,
'(2A,F8.2,3A,I4,A)')
2387 $ m_bs,
'put(0,' ,z0l,
'){',m_bs,
'line(1,0){' ,kay,
'}}' 2389 scmx = dmax1(dabs(yl),dabs(yu))
2390 lex = nint( log10(scmx) -0.50001d0)
2392 k = nint(kay*(tipsy(n)-yl)/(yu-yl))
2393 IF(lex .LT. 2.AND.lex .GT. -1)
THEN 2395 WRITE(m_ltx,
'(2A,I4,5A,F8.3,A)')
2396 $ m_bs,
'put(-25,' ,k,
'){',m_bs,
'makebox(0,0)[r]{',
2397 $ m_bs,
'large $ ' ,tipsy(n),
' $}}' 2400 WRITE(m_ltx,
'(2A,I4,5A,F8.3,2A,I4,A)')
2401 $ m_bs,
'put(-25,' ,k,
'){',m_bs,
'makebox(0,0)[r]{',
2403 $ ,tipsy(n)/(10d0**lex), m_bs,
'cdot 10^{' ,lex,
'} $}}' 2408 SUBROUTINE glk_plhist(kax,kay,nchx,yl,yu,yy,ker,yer)
2414 INTEGER kax,kay,nchx,ker
2415 DOUBLE PRECISION yl,yu,yy(*),yer(*)
2418 INTEGER IX0,ix2,idx,ie,ierr,idy,ib,iy0,iy1,ix1
2420 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2421 $ m_bs,
'put(300,250){',m_bs,
'begin{picture}( ',kax,
',',kay,
')' 2422 WRITE(m_ltx,
'(A)')
'% ========== plotting primitives ==========' 2424 IF(m_tline .EQ. 1)
THEN 2425 WRITE(m_ltx,
'(2A)') m_bs,
'thicklines ' 2427 WRITE(m_ltx,
'(2A)') m_bs,
'thinlines ' 2431 $ m_bs,
'newcommand{',m_bs,
'x}[3]{',m_bs,
'put(#1,#2){',
2432 $ m_bs,
'line(1,0){#3}}}' 2434 $ m_bs,
'newcommand{',m_bs,
'y}[3]{',m_bs,
'put(#1,#2){',
2435 $ m_bs,
'line(0,1){#3}}}' 2437 $ m_bs,
'newcommand{',m_bs,
'z}[3]{',m_bs,
'put(#1,#2){',
2438 $ m_bs,
'line(0,-1){#3}}}' 2441 $ m_bs,
'newcommand{',m_bs,
'e}[3]{',
2442 $ m_bs,
'put(#1,#2){',m_bs,
'line(0,1){#3}}}' 2446 ix1 = nint(kax*(ib-0.00001)/nchx)
2447 iy1 = nint(kay*(yy(ib)-yl)/(yu-yl))
2450 fmt1 =
'(2(2A,I4,A,I4,A,I4,A))' 2451 IF( idy .GE. 0)
THEN 2452 IF(iy1 .GE. 0.AND.iy1 .LE. kay)
2453 $
WRITE(m_ltx,fmt1) m_bs,
'y{',ix0,
'}{',iy0,
'}{',idy,
'}',
2454 $ m_bs,
'x{',ix0,
'}{',iy1,
'}{',idx,
'}' 2456 IF(iy1 .GE. 0.AND.iy1 .LE. kay)
2457 $
WRITE(m_ltx,fmt1) m_bs,
'z{',ix0,
'}{',iy0,
'}{',-idy,
'}',
2458 $ m_bs,
'x{',ix0,
'}{',iy1,
'}{',idx,
'}' 2463 ix2 = nint(kax*(ib-0.5000d0)/nchx)
2464 ierr = nint(kay*((yy(ib)-yer(ib))-yl)/(yu-yl))
2465 ie = nint(kay*yer(ib)/(yu-yl))
2466 IF(iy1 .GE. 0.AND.iy1 .LE. kay.and.abs(ierr) .LE. 9999
2467 $ .and.2*ie .LE. 9999)
WRITE(m_ltx,8000) m_bs,ix2,ierr,ie*2
2470 8000
FORMAT(4(a1,2he{,i4,2h}{,i5,2h}{,i4,1h}:1x ))
2471 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}',
2472 $
' % end of plotting histogram' 2475 IF(m_tline .GT. 2) m_tline=1
2478 SUBROUTINE glk_plhis2(kax,kay,nchx,yl,yu,yy,ker,yer)
2484 DOUBLE PRECISION yl,yu,yy(*),yer(*)
2485 INTEGER kax,kay,nchx,ker
2487 INTEGER iy1,ierr,ie,ix1,irad1,irad2,ib
2490 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2491 $ m_bs,
'put(300,250){',m_bs,
'begin{picture}( ',kax,
',',kay,
')' 2492 WRITE(m_ltx,
'(A)')
'% ========== plotting primitives ==========' 2496 IF(m_tline .EQ. 1)
THEN 2498 WRITE(m_ltx,
'(8A,I3,A)')
2499 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2500 $ m_bs,
'put(#1,#2){',m_bs,
'circle*{',irad1,
'}}}' 2501 ELSEIF(m_tline .EQ. 2)
THEN 2503 WRITE(m_ltx,
'(8A,I3,A)')
2504 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2505 $ m_bs,
'put(#1,#2){',m_bs,
'circle{',irad1,
'}}}' 2506 ELSEIF(m_tline .EQ. 3)
THEN 2508 WRITE(m_ltx,
'(8A,I3,A)')
2509 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2510 $ m_bs,
'put(#1,#2){',m_bs,
'circle*{',irad2,
'}}}' 2511 ELSEIF(m_tline .EQ. 4)
THEN 2513 WRITE(m_ltx,
'(8A,I3,A)')
2514 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2515 $ m_bs,
'put(#1,#2){',m_bs,
'circle{',irad2,
'}}}' 2517 ELSEIF(m_tline .EQ. 5)
THEN 2518 WRITE(m_ltx,
'(10A)')
2519 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2520 $ m_bs,
'put(#1,#2){',m_bs,
'makebox(0,0){$',m_bs,
'diamond$}}}' 2522 WRITE(m_ltx,
'(10A)')
2523 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2524 $ m_bs,
'put(#1,#2){',m_bs,
'makebox(0,0){$',m_bs,
'star$}}}' 2528 $ m_bs,
'newcommand{',m_bs,
'E}[3]{',
2529 $ m_bs,
'put(#1,#2){',m_bs,
'line(0,1){#3}}}' 2531 ix1 = nint(kax*(ib-0.5000d0)/nchx)
2532 iy1 = nint(kay*(yy(ib)-yl)/(yu-yl))
2533 IF(iy1 .GE. 0.AND.iy1 .LE. kay)
WRITE(m_ltx,7000) m_bs,ix1,iy1
2535 ierr = nint(kay*((yy(ib)-yer(ib))-yl)/(yu-yl))
2536 ie = nint(kay*yer(ib)/(yu-yl))
2537 IF(iy1 .GE. 0.AND.iy1 .LE. kay.and.abs(ierr) .LE. 9999
2538 $ .and.2*ie .LE. 9999)
WRITE(m_ltx,8000) m_bs,ix1,ierr,ie*2
2541 7000
FORMAT(4(a1,2hr{,i4,2h}{,i4,1h}:1x ))
2542 8000
FORMAT(4(a1,2he{,i4,2h}{,i5,2h}{,i4,1h}:1x ))
2543 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}',
2544 $
' % end of plotting histogram' 2547 IF(m_tline .GT. 6) m_tline=1
2550 SUBROUTINE glk_plcirc(kax,kay,nchx,yl,yu,yy)
2555 INTEGER kax,kay,nchx
2556 DOUBLE PRECISION yl,yu,yy(*)
2558 INTEGER IX(m_MaxNb),IY(m_MaxNb)
2559 DOUBLE PRECISION ai0,dx,aj0,ds,facy,aj,ai
2560 INTEGER ipnt,i,iter,ipoin,irad1,irad2
2561 DOUBLE PRECISION GLK_AproF
2569 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2570 $ m_bs,
'put(300,250){',m_bs,
'begin{picture}( ',kax,
',',kay,
')' 2571 WRITE(m_ltx,
'(A)')
'% ========== plotting primitives ==========' 2572 IF(m_tline .EQ. 1)
THEN 2575 WRITE(m_ltx,
'(8A,I3,A)')
2576 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2577 $ m_bs,
'put(#1,#2){',m_bs,
'circle*{',irad1,
'}}}' 2578 ELSEIF(m_tline .EQ. 2)
THEN 2581 WRITE(m_ltx,
'(8A,I3,A)')
2582 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2583 $ m_bs,
'put(#1,#2){',m_bs,
'circle{',irad1,
'}}}' 2584 ELSEIF(m_tline .EQ. 3)
THEN 2587 WRITE(m_ltx,
'(8A,I3,A)')
2588 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2589 $ m_bs,
'put(#1,#2){',m_bs,
'circle*{',irad2,
'}}}' 2590 ELSEIF(m_tline .EQ. 4)
THEN 2593 WRITE(m_ltx,
'(8A,I3,A)')
2594 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2595 $ m_bs,
'put(#1,#2){',m_bs,
'circle{',irad2,
'}}}' 2597 ELSEIF(m_tline .EQ. 5)
THEN 2599 WRITE(m_ltx,
'(10A)')
2600 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2601 $ m_bs,
'put(#1,#2){',m_bs,
'makebox(0,0){$',m_bs,
'diamond$}}}' 2604 WRITE(m_ltx,
'(10A)')
2605 $ m_bs,
'newcommand{',m_bs,
'R}[2]{',
2606 $ m_bs,
'put(#1,#2){',m_bs,
'makebox(0,0){$',m_bs,
'star$}}}' 2611 aj = (glk_aprof( (ai/kax)*nchx+0.5d0, nchx, yy) -yl)*facy
2623 aj = (glk_aprof( (ai/kax)*nchx+0.5d0, nchx, yy) -yl)*facy
2624 dx = dx *ds/sqrt(dx**2 + (aj-aj0)**2)
2626 IF(int(aj) .GE. 0.AND.int(aj) .LE. kay.AND.int(ai) .LE. kax)
THEN 2633 IF(int(ai) .GT. kax)
GOTO 101
2636 WRITE(m_ltx,7000) (m_bs,ix(i),iy(i), i=1,ipnt)
2637 7000
FORMAT(4(a1,2hr{,i4,2h}{,i4,1h}:1x ))
2638 WRITE(m_ltx,
'(2A)') m_bs,
'end{picture}} % end of plotting line' 2641 IF(m_tline .GT. 2) m_tline=1
2644 DOUBLE PRECISION FUNCTION glk_aprof(px,nch,yy)
2649 DOUBLE PRECISION px,yy(*),X,p
2652 IF(x .LT. 0.0.OR.x .GT. float(nch+1))
THEN 2658 IF(ip .GT. nch-2) ip=nch-2
2661 $ -(1./6.)*p*(p-1)*(p-2) *yy(ip-1)
2662 $ +(1./2.)*(p*p-1)*(p-2) *yy(ip )
2663 $ -(1./2.)*p*(p+1)*(p-2) *yy(ip+1)
2664 $ +(1./6.)*p*(p*p-1) *yy(ip+2)
2667 SUBROUTINE glk_pltitle(title)
2675 CALL glk_copch(title,m_titch(1))
2678 SUBROUTINE glk_plcapt(lines)
2685 CHARACTER*80 lines(*)
2693 m_keytit= m_keytit+1
2694 IF(lines(i) .EQ.
'% end-of-caption' )
GOTO 100
2696 CALL glk_retu1(
' WARNING from GLK_PlCapt: to many lines =',m_titlen
2700 SUBROUTINE glk_pllabel(lines)
2706 CHARACTER*80 lines(*)
2714 m_keytit= m_keytit+1
2715 IF(lines(i) .EQ.
'% end-of-label' )
GOTO 100
2717 CALL glk_retu1(
' WARNING from GLK_PlLabel: to many lines =',m_titlen
2726 WRITE(m_ltx,
'(A)') m_titch(i)
2731 WRITE(m_ltx,
'(2A)') m_bs,
'end{picture} % close entire picture ' 2732 IF(abs(m_lint) .EQ. 2)
THEN 2733 WRITE(m_ltx,
'(A)')
'%====== end of GLK_PlLabel ==========' 2735 WRITE(m_ltx,
'(2A)') m_bs,
'end{figure}' 2740 SUBROUTINE glk_plot2(id,ch1,ch2,chmark,chxfmt,chyfmt)
2769 CHARACTER ch1,ch2,chmark*(*)
2770 CHARACTER*8 chxfmt,chyfmt
2773 DOUBLE PRECISION yy(m_MaxNb),yer(m_MaxNb)
2777 INTEGER kax,kay,incr,ker,nchx
2778 INTEGER iopsla,ioplog,ioperb,iopsc1,iopsc2,idum
2779 DOUBLE PRECISION dxl,dxu,xu,xl,yu,yl
2783 CHARACTER*1 chre, chrp1
2784 parameter( chre =
'E', chrp1=
'R' )
2787 CHARACTER*1 chrx(12)
2788 DATA chrx /
'a',
'b',
'c',
'd',
'f',
'g',
'h',
'i',
'j',
'k',
'l',
'm'/
2791 IF(.NOT.glk_exist(id))
GOTO 900
2793 CALL glk_unpak(id,yy ,
' ',idum)
2794 CALL glk_unpak(id,yer,
'ERRO',idum)
2795 CALL glk_hinbo1(id,title,nchx,dxl,dxu)
2799 IF(ch1 .EQ.
'S')
THEN 2808 CALL glk_plframe(id,kax,kay,chxfmt,chyfmt)
2810 CALL glk_range1(id,yl,yu)
2816 chrp= chrp1//chrx(incr)
2817 WRITE(m_ltx,
'(A)')
'%=GLK_Plot2: next plot (line) ==========' 2818 WRITE(m_ltx,
'(A,I10)')
'%====HISTOGRAM ID=',id
2819 WRITE(m_ltx,
'(A,A70 )')
'% ',title
2820 CALL glk_optout(id,ioplog,iopsla,ioperb,iopsc1,iopsc2)
2823 IF (iopsla .EQ. 2)
THEN 2829 IF (ch2 .EQ.
'B') chr=
' ' 2831 IF (ch2 .EQ.
'*') chr=
'*' 2833 IF (ch2 .EQ.
'R') chr=
'R' 2835 IF (ch2 .EQ.
'L') chr=
'L' 2836 IF (ch2 .EQ.
'C') chr=
'C' 2838 IF (chr .EQ.
' ')
THEN 2840 CALL glk_plkont(kax,kay,nchx,yl,yu,yy,ker,yer)
2841 ELSE IF(chr .EQ.
'*' .OR. chr .EQ.
'R'.OR. chr .EQ.
'L')
THEN 2843 CALL glk_plmark(kax,kay,nchx,yl,yu,yy,ker,yer,chmark,chr,chrp,chre
2844 ELSE IF(chr .EQ.
'C')
THEN 2846 CALL glk_plcirc(kax,kay,nchx,yl,yu,yy)
2851 WRITE(m_ltx,
'(2A)') m_bs,
'end{picture} % close entire picture ' 2852 IF(abs(m_lint) .EQ. 2)
THEN 2853 WRITE(m_ltx,
'(A)')
'%== GLK_Plot2: end of plot ==========' 2855 WRITE(m_ltx,
'(2A)') m_bs,
'end{figure}' 2858 900
CALL glk_stop1(
'+++GLK_Plot2: Nonexistig histo, skipped, id= ',id)
2861 SUBROUTINE glk_plframe(id,kax,kay,chxfmt,chyfmt)
2865 CHARACTER chxfmt*(*),chyfmt*(*)
2870 DOUBLE PRECISION dxl,dxu,xl,xu,yl,yu
2871 INTEGER icont,i,nchx
2875 CALL glk_hinbo1(id,title,nchx,dxl,dxu)
2878 CALL glk_range1(id,yl,yu)
2880 IF(icont .GT. 1)
WRITE(m_ltx,
'(2A)') m_bs,
'newpage' 2884 WRITE(m_ltx,
'(A)')
' ' 2885 WRITE(m_ltx,
'(A)')
' ' 2887 $
'%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' 2889 $
'%%%%%%%%%%%%%%%%%%%%%%GLK_PlFrame%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%' 2890 IF(abs(m_lint) .EQ. 2)
THEN 2891 WRITE(m_ltx,
'(2A)') m_bs,
'noindent' 2893 WRITE(m_ltx,
'(2A)') m_bs,
'begin{figure}[!ht]' 2894 WRITE(m_ltx,
'(2A)') m_bs,
'centering' 2895 WRITE(m_ltx,
'(2A)') m_bs,
'htmlimage{scale=1.4}' 2900 IF(abs(m_lint) .NE. 2)
THEN 2902 $ m_bs,
'caption{',m_bs,
'footnotesize',m_bs,
'sf' 2904 WRITE(m_ltx,
'(A)') m_titch(i)
2906 WRITE(m_ltx,
'(A)')
'}' 2911 WRITE(m_ltx,
'(A)')
'% =========== big frame, title etc. =======' 2912 WRITE(m_ltx,
'(4A)') m_bs,
'setlength{',m_bs,
'unitlength}{0.1mm}' 2913 WRITE(m_ltx,
'(2A)') m_bs,
'begin{picture}(1600,1500)' 2914 IF( m_lint .LT. 0)
THEN 2917 $ m_bs,
'put(0,0){',m_bs,
'framebox(1600,1500){ }}' 2919 WRITE(m_ltx,
'(A)')
'% =========== small frame, labeled axis ===' 2920 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2921 $ m_bs,
'put(300,250){',m_bs,
'begin{picture}( ',kax,
',',kay,
')' 2922 WRITE(m_ltx,
'(4A,I4,A,I4,A)')
2923 $ m_bs,
'put(0,0){',m_bs,
'framebox( ',kax,
',',kay,
'){ }}' 2924 WRITE(m_ltx,
'(A)')
'% =========== x and y axis ================' 2925 CALL glk_axisx(kax,xl,xu,chxfmt)
2926 CALL glk_axisy(kay,yl,yu,chyfmt)
2927 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}' 2928 $ ,
'% end of plotting labeled axis' 2931 SUBROUTINE glk_axisx(kay,yl,yu,chxfmt)
2936 DOUBLE PRECISION yl,yu
2941 CHARACTER*64 fmt1,fmt2
2942 parameter(fmt1 =
'(2A,F8.2,A,F8.2,A,I4,3A)')
2943 parameter(fmt2 =
'(2A,F8.2,A,I4,A,F8.2,A,I4,3A)')
2944 DOUBLE PRECISION dy,ddy,ddyl,yy0l,ddys,yy0s,p0s,pds,scmx,p0l,pdl
2945 INTEGER ly,jy,nlt,nts,lex,k,n
2946 DOUBLE PRECISION tipsy(20)
2949 ly = nint( log10(dy) -0.4999999d0 )
2950 jy = nint(dy/10d0**ly)
2951 ddyl = dy*10d0**(-ly)
2952 IF( jy .EQ. 1) ddyl = 10d0**ly*0.25d0
2953 IF( jy .GE. 2 .AND. jy .LE. 3) ddyl = 10d0**ly*0.5d0
2954 IF( jy .GE. 4 .AND. jy .LE. 6) ddyl = 10d0**ly*1.0d0
2955 IF( jy .GE. 7) ddyl = 10d0**ly*2.0d0
2956 WRITE(m_ltx,
'(A)')
'% -------GLK_AxisX---- ' 2957 WRITE(m_ltx,
'(A,I4)')
'% JY= ',jy
2960 nlt = max0(min0(nlt,20),1)+1
2961 yy0l = nint(yl/ddyl+0.5d0)*ddyl
2963 yy0s = nint(yl/ddys+0.4999999d0)*ddys
2964 p0l = kay*(yy0l-yl)/(yu-yl)
2965 pdl = kay*ddyl/(yu-yl)
2966 p0s = kay*(yy0s-yl)/(yu-yl)
2967 pds = kay*ddys/(yu-yl)
2968 nlt = int(abs(yu-yy0l)/ddyl+0.0000001d0)+1
2969 nts = int(abs(yu-yy0s)/ddys+0.0000001d0)+1
2971 tipsy(n) =yy0l+ ddyl*(n-1)
2974 $ m_bs,
'multiput(' ,p0l,
',0)(' ,pdl,
',0){' ,nlt,
'}{',
2975 $ m_bs,
'line(0,1){25}}',
2976 $ m_bs,
'multiput(' ,p0s,
',0)(' ,pds,
',0){' ,nts,
'}{',
2977 $ m_bs,
'line(0,1){10}}' 2979 $ m_bs,
'multiput(' ,p0l,
',' ,kay,
')(' ,pdl,
',0){' ,nlt,
2980 $
'}{' ,m_bs,
'line(0,-1){25}}',
2981 $ m_bs,
'multiput(' ,p0s,
',' ,kay,
')(' ,pds,
',0){' ,nts,
2982 $
'}{' ,m_bs,
'line(0,-1){10}}' 2984 scmx = dmax1(dabs(yl),dabs(yu))
2985 lex = nint( log10(scmx) -0.50001)
2987 k = nint(kay*(tipsy(n)-yl)/(yu-yl))
2988 IF(lex .LE. 3 .AND. lex .GE. -3)
THEN 2990 WRITE(m_ltx,
'(2A,I4,5A,'//chxfmt//
',A)')
2991 $ m_bs,
'put(',k,
',-25){',m_bs,
'makebox(0,0)[t]{',
2992 $ m_bs,
'Large $ ', tipsy(n),
' $}}' 2995 WRITE(m_ltx,
'(2A,I4,5A,'//chxfmt//
',2A,I4,A)')
2996 $ m_bs,
'put(' ,k,
',-25){',m_bs,
'makebox(0,0)[t]{',
2998 $ tipsy(n)/(10d0**lex),m_bs,
'cdot 10^{',lex,
'} $}}' 3003 SUBROUTINE glk_axisy(kay,yl,yu,chyfmt)
3008 DOUBLE PRECISION yl,yu
3012 DOUBLE PRECISION tipsy(20)
3014 CHARACTER*64 fmt1,fmt2
3015 parameter(fmt1 =
'(2A,F8.2,A,F8.2,A,I4,3A)')
3016 parameter(fmt2 =
'(2A,I4,A,F8.2,A,F8.2,A,I4,3A)')
3017 INTEGER ly,jy,nlt,nts,lex,n,k
3018 DOUBLE PRECISION ddyl,dy,yy0l,p0l,pdl,pds,scmx,z0l,p0s,yy0s,ddys
3021 ly = nint( log10(dy) -0.49999999d0 )
3022 jy = nint(dy/10d0**ly)
3023 ddyl = dy*10d0**(-ly)
3024 IF( jy .EQ. 1) ddyl = 10d0**ly*0.25d0
3025 IF( jy .GE. 2 .AND. jy .LE. 3) ddyl = 10d0**ly*0.5d0
3026 IF( jy .GE. 4 .AND. jy .LE. 6) ddyl = 10d0**ly*1.0d0
3027 IF( jy .GE. 7) ddyl = 10d0**ly*2.0d0
3028 WRITE(m_ltx,
'(A)')
'% --------GLK_SAxisY------- ' 3029 WRITE(m_ltx,
'(A,I4)')
'% JY= ',jy
3032 nlt = max0(min0(nlt,20),1)+1
3033 yy0l = nint(yl/ddyl+0.4999999d0)*ddyl
3035 yy0s = nint(yl/ddys+0.5d0)*ddys
3036 p0l = kay*(yy0l-yl)/(yu-yl)
3037 pdl = kay*ddyl/(yu-yl)
3038 p0s = kay*(yy0s-yl)/(yu-yl)
3039 pds = kay*ddys/(yu-yl)
3040 nlt= int(abs(yu-yy0l)/ddyl+0.0000001d0) +1
3041 nts= int(abs(yu-yy0s)/ddys+0.0000001d0) +1
3043 tipsy(n) =yy0l+ ddyl*(n-1)
3047 $ m_bs,
'multiput(0,' ,p0l,
')(0,' ,pdl ,
'){' ,nlt,
'}{', m_bs
'line(1,0){25}}' 3048 'multiput(0,' ,p0s,
')(0,' ,pds,
'){' ,nts,
'}{', m_bs
'line(1,0){10}}' 3050 $ m_bs,
'multiput(' ,kay,
',' ,p0l,
')(0,' ,pdl,
'){' ,nlt,
3051 $
'}{',m_bs,
'line(-1,0){25}}',
3052 $ m_bs,
'multiput(' ,kay,
',' ,p0s,
')(0,' ,pds,
'){' ,nts,
3053 $
'}{',m_bs,
'line(-1,0){10}}' 3055 z0l = kay*(-yl)/(yu-yl)
3056 IF( (z0l .GT. 0d0) .AND. (z0l .LT. float(kay)) )
3057 $
WRITE(m_ltx,
'(2A,F8.2,3A,I4,A)') m_bs,
'put(0,' ,z0l,
'){',m_bs,
'line(1,0){''}}' 3059 scmx = dmax1(dabs(yl),dabs(yu))
3060 lex = nint( log10(scmx) -0.50001d0)
3062 k = nint(kay*(tipsy(n)-yl)/(yu-yl))
3063 IF(lex .LE. 3 .AND. lex .GE. -3)
THEN 3065 WRITE(m_ltx,
'(2A,I4,5A,'//chyfmt//
',A)')
3066 $ m_bs,
'put(-25,' ,k,
'){',m_bs,
'makebox(0,0)[r]{',
3067 $ m_bs,
'Large $ ' ,tipsy(n),
' $}}' 3070 WRITE(m_ltx,
'(2A,I4,5A,'//chyfmt//
',2A,I4,A)')
3071 $ m_bs,
'put(-25,' ,k,
'){',m_bs,
'makebox(0,0)[r]{',
3073 $ tipsy(n)/(10d0**lex), m_bs,
'cdot 10^{' ,lex,
'} $}}' 3078 SUBROUTINE glk_plkont(kax,kay,nchx,yl,yu,yy,ker,yer)
3085 INTEGER kax,kay,nchx,ker
3086 DOUBLE PRECISION yl, yu, yy(*),yer(*),z0l
3091 INTEGER ix0,iy0,ib,ix1,iy1,ie,ierr,ix2,idy,idx
3092 DOUBLE PRECISION yib
3094 WRITE(m_ltx,
'(4A,I4,A,I4,A)') m_bs,
'put(300,250){',m_bs,
'begin{picture}( '','')' 3095 WRITE(m_ltx,
'(A)')
'% ========== plotting primitives ==========' 3097 IF(m_keycol .EQ. 1)
THEN 3098 WRITE(m_ltx,
'(A)') m_color
3103 $ m_bs,
'newcommand{',m_bs,
'x}[3]{',m_bs,
'put(#1,#2){', m_bs,
'line(1,0){#3}}}' 3105 $ m_bs,
'newcommand{',m_bs,
'y}[3]{',m_bs,
'put(#1,#2){', m_bs,
'line(0,1){#3}}}' 3107 $ m_bs,
'newcommand{',m_bs,
'z}[3]{',m_bs,
'put(#1,#2){', m_bs,
'line(0,-1){#3}}}' 3110 $ m_bs,
'newcommand{',m_bs,
'e}[3]{', m_bs,
'put(#1,#2){',m_bs,
'line(0,1){#3}}}' 3115 z0l = kay*(-yl)/(yu-yl)
3116 IF( (z0l .GT. 0d0) .AND. (z0l .LT. float(kay)) ) iy0=z0l
3119 ix1 = nint(kax*(ib-0.00001d0)/nchx)
3120 iy1 = nint(kay*(yib-yl)/(yu-yl))
3121 iy1 = min(max(iy1,-1),kay+1)
3124 fmt1 =
'(2(2a,i4,a,i4,a,i4,a))' 3125 IF(iy1 .GE. 0 .AND. iy1 .LE. kay)
THEN 3126 IF( idy .GE. 0)
THEN 3127 WRITE(m_ltx,fmt1) m_bs,
'y{',ix0,
'}{',iy0,
'}{',idy,
'}',
3128 $ m_bs,
'x{',ix0,
'}{',iy1,
'}{',idx,
'}' 3130 WRITE(m_ltx,fmt1) m_bs,
'z{',ix0,
'}{',iy0,
'}{',-idy,
'}',
3131 $ m_bs,
'x{',ix0,
'}{',iy1,
'}{',idx,
'}' 3137 ix2 = nint(kax*(ib-0.5000d0)/nchx)
3138 ierr = nint(kay*((yy(ib)-yer(ib))-yl)/(yu-yl))
3139 ie = nint(kay*yer(ib)/(yu-yl))
3141 IF(ierr .LT. 0)
THEN 3145 IF( (ierr+2*ie) .GT. kay)
THEN 3146 ie= iabs(kay-ierr)/2
3148 IF( (iy1.GE.0).AND.(iy1.LE. kay).AND.(abs(1d0*ierr).LE.9999d0
3149 WRITE(m_ltx,8000) m_bs,ix2,ierr,2*ie
3152 8000
FORMAT(4(a1,2he{,i4,2h}{,i5,2h}{,i4,1h}:1x ))
3153 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}',
' % end of plotting histogram' 3156 IF(m_tline .GT. 2) m_tline=1
3159 SUBROUTINE glk_plmark(kax,kay,nchx,yl,yu,yy,ker,yer,chmark,chr,chr2,chr3)
3166 INTEGER kax,kay,nchx,ker
3167 DOUBLE PRECISION yl,yu, yy(*),yer(*)
3169 CHARACTER chmark*(*),chr2*(*),chr3*(*)
3173 INTEGER ib,ix1,iy1,ierr,ie
3175 WRITE(m_ltx,
'(4A,I4,A,I4,A)') m_bs,
'put(300,250){',m_bs,
'begin{picture}( '','')' 3176 WRITE(m_ltx,
'(A)')
'% ===GLK_PlMark: plotting primitives ======' 3178 IF(m_keycol .EQ. 1)
THEN 3179 WRITE(m_ltx,
'(A)') m_color
3183 WRITE(m_ltx,
'(10A)') m_bs,
'newcommand{',m_bs,chr2 ,
'}[2]{', m_bs
'put(#1,#2){''}}' 3185 WRITE(m_ltx,
'(10A)')
3186 $ m_bs,
'newcommand{',m_bs,chr3 ,
'}[3]{', m_bs,
'put(#1,#2){',m_bs
'line(0,1){#3}}}' 3189 IF(chr .EQ.
'*')
THEN 3190 ix1 = nint(kax*(ib-0.5000d0)/nchx)
3191 ELSEIF(chr .EQ.
'R')
THEN 3192 ix1 = nint(kax*(ib*1d0)/nchx)
3193 ELSEIF(chr .EQ.
'L')
THEN 3194 ix1 = nint(kax*(ib-1d0)/nchx)
3196 WRITE(6,*)
'+++++ plamark: wrong line type:',chr
3199 iy1 = nint(kay*(yy(ib)-yl)/(yu-yl))
3200 IF(iy1 .GE. 0 .AND. iy1 .LE. kay)
3201 $
WRITE(m_ltx,
'(A,A,A,I4,A,I4,A)')
3202 $ m_bs,chr2,
'{' ,ix1,
'}{' ,iy1,
'}' 3204 ierr = nint(kay*((yy(ib)-yer(ib))-yl)/(yu-yl))
3205 ie = nint(kay*yer(ib)/(yu-yl))
3207 IF(ierr .LT. 0)
THEN 3211 IF( (ierr+2*ie) .GT. kay)
THEN 3212 ie= iabs(kay-ierr)/2
3214 IF((iy1.GE.0) .AND.(iy1.LE.kay) .AND.(abs(1d0*ierr).LE.9999d0
3215 WRITE(m_ltx,
'(A,A,A,I4,A,I5,A,I4,A)')
3216 $ m_bs, chr3,
'{' ,ix1,
'}{' ,ierr,
'}{' ,2*ie,
'}' 3219 WRITE(m_ltx,
'(3A)') m_bs,
'end{picture}}',
3220 $
' % end of plotting histogram' 3224 SUBROUTINE glk_pltable(Npl,idl,capt,fmt,nch1,incr,npag)
3238 INTEGER Npl,idl(*),nch1,incr,npag
3239 CHARACTER*(*) capt(*)
3240 CHARACTER*(*) fmt(3)
3245 CHARACTER*16 fmt1,fmt2,fmt3
3247 INTEGER i,j,k,n,nchx,nplt,idum,id1,id
3248 INTEGER iopsc1,ioperb,iopsla,iopsc2,ioplog
3249 DOUBLE PRECISION xl,xu,dxl,dxu,xi
3250 DOUBLE PRECISION yyy(m_MaxNb),yer(m_MaxNb),bi(m_MaxNb,9),er(m_MaxNb
3253 DATA cn /
'1',
'2',
'3',
'4',
'5',
'6',
'7',
'8',
'9'/
3256 IF(.NOT.glk_exist(id))
GOTO 900
3257 IF(npl .GT. 9 )
GOTO 901
3264 CALL glk_hinbo1( id1,title,nchx,dxl,dxu)
3268 CALL glk_unpak( idl(n),yyy ,
' ',idum)
3269 CALL glk_unpak( idl(n),yer ,
'ERRO',idum)
3278 WRITE(m_ltx,
'(A)')
' ' 3279 WRITE(m_ltx,
'(A)')
' ' 3280 WRITE(m_ltx,
'(A)')
'% =========================================' 3281 WRITE(m_ltx,
'(A)')
'% ============= begin table ===============' 3282 WRITE(m_ltx,
'(2A)') m_bs,
'begin{table}[!ht]' 3283 WRITE(m_ltx,
'(2A)') m_bs,
'centering' 3287 WRITE(m_ltx,
'(4A)') m_bs,
'caption{',m_bs,
'small' 3289 WRITE(m_ltx,
'(A)') m_titch(i)
3291 WRITE(m_ltx,
'(A)')
'}' 3295 WRITE(m_ltx,
'(20A)') m_bs,
'begin{tabular} 3296 $ {|', (
'|c',j=1,npl+1),
'||}' 3298 WRITE(m_ltx,
'(4A)') m_bs,
'hline',m_bs,
'hline' 3302 WRITE(m_ltx,
'(2A)') capt(1),(
'&',capt(j+1),j=1,npl)
3304 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3305 WRITE(m_ltx,
'(2A)') m_bs,
'hline' 3311 CALL glk_optout(idl(1),ioplog,iopsla,ioperb,iopsc1,iopsc2)
3313 xi= dxl + (dxu-dxl)*k/(1d0*nchx)
3314 IF(iopsla.eq.2) xi= dxl + (dxu-dxl)*(k-0.5d0)/(1d0*nchx)
3315 IF(ioperb.eq.2)
THEN 3316 WRITE(m_ltx,
'(A,'//fmt1//
','//cn(npl)//
'(A,'//fmt2//
',A,A,'//fmt3
'), A)' 3317 '$', xi, (
'$ & $', bi(k,j), m_bs,
'pm', er(k,j), j=
'$' 3318 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3320 WRITE(m_ltx,
'(A,'//fmt1//
','//cn(npl)//
'(A,'//fmt2//
'), A)')
3321 $
'$', xi, (
'$ & $', bi(k,j), j=1,npl),
'$' 3322 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3328 WRITE(m_ltx,
'(4A)') m_bs,
'hline',m_bs,
'hline' 3329 WRITE(m_ltx,
'(2A)') m_bs,
'end{tabular}' 3330 WRITE(m_ltx,
'(2A)') m_bs,
'end{table}' 3331 WRITE(m_ltx,
'(A)')
'% ============= end table ===============' 3332 WRITE(m_ltx,
'(A)')
'% =========================================' 3333 IF(npag .NE. 0)
WRITE(m_ltx,
'(2A)') m_bs,
'newpage' 3336 900
CALL glk_retu1(
'++++ GLK_PlTable: Nonexistig histo id=',id)
3338 901
CALL glk_retu1(
'++++ GLK_PlTable: To many columns Nplt=',nplt)
3341 SUBROUTINE glk_pltable2(Npl,idl,ccapt,mcapt,fmt,chr1,chr2,chr3)
3364 CHARACTER*(*) ccapt(*)
3365 CHARACTER*(*) fmt(3)
3366 CHARACTER*1 chr1,chr2,chr3
3372 CHARACTER*16 fmt1,fmt2,fmt3
3374 INTEGER iopsc1,ioperb,iopsla,iopsc2,ioplog
3375 INTEGER i,j,k,n,idum,id1,id,nchx,Nplt
3376 DOUBLE PRECISION xl,xu,xi,dxu,dxl
3377 DOUBLE PRECISION yyy(m_MaxNb),yer(m_MaxNb),bi(m_MaxNb,9),er(m_MaxNb
3381 DATA cn /
'1',
'2',
'3',
'4',
'5',
'6',
'7',
'8',
'9'/
3384 IF(.NOT.glk_exist(id))
GOTO 900
3385 IF(npl .GT. 9 )
GOTO 901
3392 CALL glk_hinbo1( id1,title,nchx,dxl,dxu)
3396 CALL glk_unpak( idl(n),yyy ,
' ',idum)
3397 CALL glk_unpak( idl(n),yer ,
'ERRO',idum)
3404 IF(chr1 .EQ.
' ' )
THEN 3408 WRITE(m_ltx,
'(A)')
' ' 3409 WRITE(m_ltx,
'(A)')
' ' 3410 WRITE(m_ltx,
'(A)')
'% ========================================' 3411 WRITE(m_ltx,
'(A)')
'% ============ begin table ===============' 3413 IF(abs(m_lint) .EQ. 2 )
THEN 3414 WRITE(m_ltx,
'(2A)') m_bs,
'noindent' 3416 WRITE(m_ltx,
'(2A)') m_bs,
'begin{table}[!ht]' 3417 WRITE(m_ltx,
'(2A)') m_bs,
'centering' 3422 IF(abs(m_lint) .NE. 2 )
THEN 3424 $ m_bs,
'caption{',m_bs,
'footnotesize',m_bs,
'sf' 3426 WRITE(m_ltx,
'(A)') m_titch(i)
3428 WRITE(m_ltx,
'(A)')
'}' 3433 WRITE(m_ltx,
'(20A)') m_bs,
'begin{tabular} 3434 $ {|', (
'|c',j=1,npl+1),
'||}' 3435 WRITE(m_ltx,
'(4A)') m_bs,
'hline',m_bs,
'hline' 3439 WRITE(m_ltx,
'(2A)') ccapt(1),(
'&',ccapt(j+1),j=1,npl)
3443 ELSEIF(chr1 .EQ.
'S' )
THEN 3448 WRITE(*,*)
' ++++ GLK_PlTable2: WRONG chr1 ' ,chr1
3451 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3452 WRITE(m_ltx,
'(2A)') m_bs,
'hline' 3457 IF(mcapt .NE.
' ')
THEN 3458 WRITE(m_ltx,
'(3A,I2,A)')
'& ',m_bs,
'multicolumn{',npl,
'}{c||}{' 3459 WRITE(m_ltx,
'(3A)')
' ',mcapt,
' }' 3460 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3461 WRITE(m_ltx,
'(2A)') m_bs,
'hline' 3469 CALL glk_optout(idl(1),ioplog,iopsla,ioperb,iopsc1,iopsc2)
3475 IF( m_keytbr .EQ. 1 )
THEN 3476 k1 = max(k1,m_tabran(1))
3477 k2 = min(k2,m_tabran(2))
3478 k3 = max(k3,m_tabran(3))
3483 IF(chr2 .EQ.
'R')
THEN 3485 xi= dxl + (dxu-dxl)*k/(1d0*nchx)
3486 ELSEIF(chr2 .EQ.
'L')
THEN 3488 xi= dxl + (dxu-dxl)*(k-1d0)/(1d0*nchx)
3491 xi= dxl + (dxu-dxl)*(k-0.5d0)/(1d0*nchx)
3493 IF(ioperb.eq.2)
THEN 3494 WRITE(m_ltx,
'(A,'//fmt1//
','//cn(npl)//
'(A,'//fmt2//
',A,A,'//fmt3
'), A)' 3495 '$', xi, (
'$ & $', bi(k,j), m_bs,
'pm', er(k,j), j
'$' 3496 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3498 WRITE(m_ltx,
'(A,'//fmt1//
','//cn(npl)//
'(A,'//fmt2//
'), A)')
3499 $
'$', xi, (
'$ & $', bi(k,j), j=1,npl),
'$' 3500 WRITE(m_ltx,
'(2A)') m_bs,m_bs
3506 WRITE(m_ltx,
'(4A)') m_bs,
'hline',m_bs,
'hline' 3507 WRITE(m_ltx,
'(2A)') m_bs,
'end{tabular}' 3508 IF(abs(m_lint) .EQ. 2 )
THEN 3509 WRITE(m_ltx,
'(A)')
'% ========================================' 3511 WRITE(m_ltx,
'(2A)') m_bs,
'end{table}' 3513 WRITE(m_ltx,
'(A)')
'% ============= end table ==============' 3514 WRITE(m_ltx,
'(A)')
'% ========================================' 3515 IF(chr3 .EQ.
'E')
THEN 3516 WRITE(m_ltx,
'(2A)') m_bs,
'newpage' 3518 WRITE(m_ltx,
'(A)')
'% ========================================' 3521 900
CALL glk_retu1(
' ++++ GLK_PlTable2: Nonexistig histo,id= ',id)
3523 901
CALL glk_retu1(
' ++++ GLK_PlTable2: To many columns Nplt= ',nplt)
3527 SUBROUTINE glk_wtmon(mode,id,par1,par2,par3)
3580 DOUBLE PRECISION par1,par2,par3
3582 INTEGER idg,nevneg,nevzer,nevtot,nevove,nevacc,nbin,lact
3583 DOUBLE PRECISION xl,xu,errela,sswt,averwt,wwmax,swt,wt,wtmax,rn
3587 CALL glk_stop1(
' =====> GLK_WtMon: wrong id= ',id)
3589 IF(mode .EQ. -1)
THEN 3591 nbin = nint(dabs(par3))
3592 IF(nbin .GT. 100) nbin =100
3593 IF(nbin .EQ. 0) nbin =1
3600 CALL glk_hadres(idg,lact)
3601 IF(lact .EQ. 0)
THEN 3602 CALL glk_book1(idg,
' GLK_WtMon $',nbin,xl,xu)
3604 WRITE(m_out,*)
' WARNING GLK_WtMon: exists, id= ',id
3605 WRITE( 6,*)
' WARNING GLK_WtMon: exists, id= ',id
3607 ELSEIF(mode .EQ. 0)
THEN 3609 CALL glk_hadres(idg,lact)
3610 IF(lact .EQ. 0)
THEN 3611 WRITE(m_out,*)
' *****> GLK_WtMon: uninitialized, id= ',id
3612 WRITE( 6,*)
' *****> GLK_WtMon: uninitialized, id= ',id
3613 CALL glk_book1(idg,
' GLK_WtMon $',1,0d0,1d0)
3614 CALL glk_hadres(idg,lact)
3620 CALL glk_fil1(idg,wt,1d0)
3622 ist = m_index(lact,2)
3626 m_b(ist3+13) = max( dabs(m_b(ist3+13)) ,dabs(wt))
3627 IF(wt .NE. 0d0) m_b(ist3+13)=m_b(ist3+13) *wt/dabs(wt)
3629 IF(wt .EQ. 0d0) m_b(ist3+10) =m_b(ist3+10) +1d0
3630 IF(wt .GT. wtmax) m_b(ist3+11) =m_b(ist3+11) +1d0
3631 IF(rn*wtmax .LE. wt) m_b(ist3+12) =m_b(ist3+12) +1d0
3632 ELSEIF(mode .GE. 1 .OR. mode .LE. 10)
THEN 3634 CALL glk_hadres(idg,lact)
3635 IF(lact .EQ. 0)
THEN 3636 CALL glk_stop1(
' lack of initialization, id=',id)
3638 ist = m_index(lact,2)
3641 ntot = nint(m_b(ist3 +7))
3644 IF(ntot.LE.0 .OR. swt.EQ.0d0 )
THEN 3648 averwt=swt/float(ntot)
3649 errela=sqrt(abs(sswt/swt**2-1d0/float(ntot)))
3651 nevneg = m_b(ist3 +1)
3652 nevzer = m_b(ist3 +10)
3653 nevove = m_b(ist3 +11)
3654 nevacc = m_b(ist3 +12)
3655 wwmax = m_b(ist3 +13)
3661 IF(mode .EQ. 2)
THEN 3665 ELSEIF(mode .EQ. 3)
THEN 3671 IF(mode .LE. 9)
RETURN 3672 WRITE(m_out,1003) id, averwt, errela, wwmax
3673 WRITE(m_out,1004) nevtot,nevacc,nevneg,nevove,nevzer
3674 IF(mode .LE. 10)
RETURN 3678 CALL glk_stop1(
'+++GLK_WtMon: wrong mode=',mode)
3682 $
' ======================= GLK_WtMon =========================' 3683 $/,
' id averwt errela wwmax' 3684 $/, i5, e17.7, f15.9, e17.7)
3686 $
' -----------------------------------------------------------' 3687 $/,
' nevtot nevacc nevneg nevove nevzer' 3691 SUBROUTINE glk_cumhis(IdGen,id1,id2)
3701 INTEGER IdGen,id1,id2
3707 DOUBLE PRECISION X(m_MaxNb),ER(m_MaxNb)
3709 DOUBLE PRECISION swt,sswt,xsec,errel,tmin,tmax
3710 DOUBLE PRECISION xscrnb,ERela,WtSup
3712 DOUBLE PRECISION GLK_hi,GLK_hie
3714 IF (glk_exist(id2))
GOTO 900
3716 CALL glk_mgetntot(idgen,nevt)
3717 CALL glk_mgetave( idgen,xscrnb,erela,wtsup)
3719 IF(nevt .EQ. 0)
GOTO 901
3720 CALL glk_hinbo1(id1,title,nbt,tmin,tmax)
3721 swt = glk_hi( id1,0)
3722 sswt = glk_hie(id1,0)**2
3724 swt = swt + glk_hi( id1,i)
3725 sswt = sswt+ glk_hie(id1,i)**2
3730 IF(swt .NE. 0d0 .AND. nevt .NE. 0)
THEN 3731 xsec = swt*(xscrnb/nevt)
3732 errel = sqrt(abs(sswt/swt**2-1d0/float(nevt)))
3738 CALL glk_book1(id2,title,nbt,tmin,tmax)
3739 CALL glk_pak( id2,x)
3740 CALL glk_pake( id2,er)
3741 CALL glk_idopt(id2,
'ERRO')
3743 900
WRITE(6,*)
'+++++ CUMHIS: ID2 exixsts!!',id2
3745 901
WRITE(6,*)
'+++++ CUMHIS: EMPTY HISTO ID=',id1
3751 SUBROUTINE glk_renhst(chak,IdGen,id1,id2)
3764 INTEGER IdGen,id1,id2
3769 DOUBLE PRECISION xscrnb,ERela,WtSup,tmin,tmax
3770 DOUBLE PRECISION swt,fln10,fact
3772 DOUBLE PRECISION GLK_hi,GLK_hie
3774 IF( id2 .eq. id1)
GOTO 900
3776 CALL glk_mgetntot(idgen,nevt)
3777 CALL glk_mgetave( idgen,xscrnb,erela,wtsup)
3779 CALL glk_hinbo1(id1,title,nbt,tmin,tmax)
3780 IF( chak .EQ.
'NB ')
THEN 3781 fact = nbt*xscrnb/(nevt*(tmax-tmin))
3782 CALL glk_operat(id1,
'+',id1,id2, fact, 0d0)
3783 ELSEIF( chak .EQ.
'NB10')
THEN 3785 fact = nbt*xscrnb/(nevt*(tmax-tmin)*fln10)
3786 CALL glk_operat(id1,
'+',id1,id2, fact, 0d0)
3787 ELSEIF( chak .EQ.
'UNIT')
THEN 3790 swt = swt + glk_hi(id1,i)
3792 fact = nbt/((tmax-tmin))/swt
3793 CALL glk_operat(id1,
'+',id1,id2, fact, 0d0)
3794 ELSEIF( chak .EQ.
'UN10')
THEN 3797 swt = swt + glk_hi(id1,i)
3799 fact = nbt/((tmax-tmin)*log(10.))/swt
3800 CALL glk_operat(id1,
'+',id1,id2, fact, 0d0)
3801 ELSEIF( chak .EQ.
' ')
THEN 3802 CALL glk_operat(id1,
'+',id1,id2, 1d0, 0d0)
3804 WRITE(6,*)
'+++++ RENHST: wrong chak=',chak
3808 900
WRITE(6,*)
'+++++ RENHST: ID1=ID2=',id1
3830 SUBROUTINE glk_mbook(idm,title,nnchx,WTmax)
3844 DOUBLE PRECISION WTmax
3847 INTEGER j,id,nnchx,nchx,lact,lengt2,ist,ist2,ist3
3848 INTEGER iopsc1, iopsc2, ioperb, ioplog, iopsla
3849 INTEGER iflag1, iflag2
3851 DOUBLE PRECISION xl,xu,ddx
3855 IF(glk_exist(id))
goto 900
3857 CALL glk_hadres(0,lact)
3859 IF(lact .EQ. 0)
CALL glk_stop1(
'GLK_Mbook: no space left,id= ',id)
3861 m_index(lact,2)=m_length
3864 CALL glk_copch(title,m_titlc(lact))
3866 IF(nchx .GT. m_maxnb)
3867 $
CALL glk_stop1(
' GLK_Mbook: Too many bins ,id= ',id)
3871 lengt2 = m_length +2*nchx +m_buf1+1
3872 IF(lengt2 .GE. m_lenmb)
3873 $
CALL glk_stop1(
'GLK_Mbook:too litle storage, m_LenmB= ',m_lenmb)
3875 DO j=m_length+1,lengt2+1
3886 $ ioplog+10*iopsla+100*ioperb+1000*iopsc1+10000*iopsc2
3901 m_b(ist +1) = 9999999999999d0
3902 m_b(ist +2) = 9d12 + id*10 +9d0
3903 m_b(ist +3) = 9d12 + iflag1*10 +9d0
3904 m_b(ist +4) = 9d12 + iflag2*10 +9d0
3906 m_b(ist +5) = -100d0
3917 $
CALL glk_stop1(
' GLK_Mbook: xl=xu, id= ',id)
3918 m_b(ist2 +4) = float(nchx)/ddx
3927 900
CALL glk_retu1(
' WARNING GLK_Mbook: already exists id= ', id)
3931 SUBROUTINE glk_mfill(idm,Wtm,rn)
3942 DOUBLE PRECISION Wtm,rn
3946 INTEGER lact, ist, ist2, ist3, iflag2, nchx, ityphi
3947 INTEGER iposx1,ipose1, kposx1, kpose1, kx
3948 DOUBLE PRECISION Wt, deltx, factx, xlowedge
3949 DOUBLE PRECISION xu, xl, x1, wtmax
3953 CALL glk_hadres(id,lact)
3956 $
CALL glk_stop1(
'+++GLK_Mfill: nonexisting id= ',id)
3958 ist = m_index(lact,2)
3962 iflag2 = nint(m_b(ist+4)-9d0-9d12)/10
3963 ityphi = mod(iflag2,10)
3964 IF(ityphi .NE. 3)
CALL glk_stop1(
'+++GLK_Mfill: wrong id= ',id)
3966 m_index(lact,3)=m_index(lact,3)+1
3968 m_b(ist3 +7) =m_b(ist3 +7) +1
3969 m_b(ist3 +8) =m_b(ist3 +8) +x1
3970 m_b(ist3 +9) =m_b(ist3 +9) +x1*x1
3976 factx = m_b(ist2 +4)
3982 m_b(iposx1) = m_b(iposx1) +1d0
3983 m_b(ipose1) = m_b(ipose1) +wt
3984 ELSEIF(x1 .GT. xu)
THEN 3989 m_b(iposx1) = m_b(iposx1) +1d0
3990 m_b(ipose1) = m_b(ipose1) +(wt- wtmax)
3995 m_b(iposx1) = m_b(iposx1) +1d0
3996 m_b(ipose1) = m_b(ipose1) +wt
3998 kx = (x1-xl)*factx+1d0
3999 kx = min( max(kx,1) ,nchx)
4000 kposx1 = ist +m_buf1+kx
4001 kpose1 = ist +m_buf1+nchx+kx
4002 xlowedge = deltx*(kx-1)
4003 m_b(kposx1) = m_b(kposx1) +1d0
4004 m_b(kpose1) = m_b(kpose1) +(wt-xlowedge)
4009 m_b(ist3+13) = max( dabs(m_b(ist3+13)) ,dabs(wt))
4010 IF(wt .NE. 0d0) m_b(ist3+13)=m_b(ist3+13) *wt/dabs(wt)
4012 IF(wt .EQ. 0d0) m_b(ist3+10) =m_b(ist3+10) +1d0
4013 IF(wt .GT. wtmax) m_b(ist3+11) =m_b(ist3+11) +1d0
4014 IF(rn*wtmax .LE. wt) m_b(ist3+12) =m_b(ist3+12) +1d0
4019 SUBROUTINE glk_mgetall(idm,
4020 $ AveWt,ERela, WtSup, AvUnd, AvOve,
4021 $ Ntot,Nacc,Nneg,Nove,Nzer)
4030 DOUBLE PRECISION AveWt,ERela, WtSup, AvUnd, AvOve
4031 INTEGER Ntot,Nacc,Nneg,Nove,Nzer
4034 INTEGER id,ist,ist2,ist3,lact
4035 DOUBLE PRECISION swt,sswt
4038 CALL glk_hadres(id,lact)
4040 $
CALL glk_stop1(
'GLK_MgetAll:lack of initialization, id=',id)
4041 ist = m_index(lact,2)
4044 ntot = nint(m_b(ist3 +7))
4047 IF(ntot.LE.0 .OR. swt.EQ.0d0 )
THEN 4051 avewt=swt/dfloat(ntot)
4052 erela=sqrt(abs(sswt/swt**2-1d0/float(ntot)))
4054 wtsup = m_b(ist3 +13)
4055 avund = m_b(ist3 +4)/ntot
4056 avove = m_b(ist3 +6)/ntot
4058 nzer = m_b(ist3 +10)
4059 nove = m_b(ist3 +11)
4060 nacc = m_b(ist3 +12)
4075 SUBROUTINE glk_mgetntot(id,Ntot)
4085 DOUBLE PRECISION AveWt, ERela, WtSup, AvUnd, AvOve
4086 INTEGER Ntot, Nacc, Nneg, Nove, Nzer
4088 CALL glk_mgetall(id,
4089 $ avewt,erela, wtsup, avund, avove,
4090 $ ntot,nacc,nneg,nove,nzer)
4093 SUBROUTINE glk_mgetave(id,AveWt,ERela,WtSup)
4103 DOUBLE PRECISION AveWt, ERela, WtSup, AvUnd, AvOve
4104 INTEGER Ntot, Nacc, Nneg, Nove, Nzer
4106 CALL glk_mgetall(id,
4107 $ avewt,erela, wtsup, avund, avove,
4108 $ ntot,nacc,nneg,nove,nzer)
4111 SUBROUTINE glk_mprint(idm)
4134 SUBROUTINE glk_clone1(id1,id2,title2)
4138 CHARACTER*80 title1, title2, title3
4140 DOUBLE PRECISION xmin,xmax
4142 CALL glk_hinbo1(id1,title1,nb,xmin,xmax)
4143 CALL glk_copch(title2,title3)
4144 CALL glk_book1(id2,title3,nb,xmin,xmax)
4148 SUBROUTINE glk_ymimax(id,wmin,wmax)
4154 DOUBLE PRECISION wmin,wmax
4156 CALL glk_yminim(id,wmin)
4157 CALL glk_ymaxim(id,wmax)
4161 SUBROUTINE glk_plset(ch,xx)
4173 IF(ch .EQ.
'DMOD')
THEN 4178 SUBROUTINE glk_setnout(ilun)
4193 SUBROUTINE glk_getymin(id,ymin)
4200 DOUBLE PRECISION ymin
4203 CALL glk_hadres(id,lact)
4204 IF(lact .EQ. 0)
RETURN 4205 ist= m_index(lact,2)
4209 SUBROUTINE glk_getymax(id,ymax)
4216 DOUBLE PRECISION ymax
4219 CALL glk_hadres(id,lact)
4220 IF(lact .EQ. 0)
RETURN 4221 ist= m_index(lact,2)
4225 SUBROUTINE glk_setymin(id,ymin)
4232 DOUBLE PRECISION ymin
4235 CALL glk_hadres(id,lact)
4236 IF(lact .EQ. 0)
RETURN 4237 ist= m_index(lact,2)
4239 CALL glk_idopt(id,
'YMIN')
4242 SUBROUTINE glk_setymax(id,ymax)
4249 DOUBLE PRECISION ymax
4252 CALL glk_hadres(id,lact)
4253 IF(lact .EQ. 0)
RETURN 4254 ist= m_index(lact,2)
4256 CALL glk_idopt(id,
'YMAX')
4260 SUBROUTINE glk_getyminymax(id,ymin,ymax)
4267 DOUBLE PRECISION ymin,ymax
4269 CALL glk_getymin(id,ymin)
4270 CALL glk_getymax(id,ymax)
4273 SUBROUTINE glk_setyminymax(id,ymin,ymax)
4280 DOUBLE PRECISION ymin,ymax
4282 CALL glk_setymin(id,ymin)
4283 CALL glk_setymax(id,ymax)
4286 SUBROUTINE glk_copyymin(id1,id2)
4293 DOUBLE PRECISION ymin
4295 CALL glk_getymin(id1,ymin)
4296 CALL glk_setymin(id2,ymin)
4299 SUBROUTINE glk_copyymax(id1,id2)
4306 DOUBLE PRECISION ymax
4308 CALL glk_getymax(id1,ymax)
4309 CALL glk_setymax(id2,ymax)
4312 SUBROUTINE glk_setcolor(Color)
4322 CALL glk_copch(color,m_color)
4327 SUBROUTINE glk_settabran(i1,i2,i3)
4344 SUBROUTINE glk_getnb(id,Nb)
4353 INTEGER lact,ist,ist2
4355 CALL glk_hadres(id,lact)
4356 IF(lact .EQ. 0)
THEN 4357 CALL glk_stop1(
'+++STOP in GLK_GetNb: wrong id=',id)
4359 ist = m_index(lact,2)
4364 SUBROUTINE glk_getbin(id,ib,Bin)
4373 DOUBLE PRECISION Bin,GLK_hi