PHOS/reconstruction/gamma00_v3.f

   1         SUBROUTINE GAMMA0(ng,mg,eg,glthr,ff)
   2
   3 C
   4 C K+  12.90  KOLOSOV V.N.
   5 C     14.03.92
   6 C              SIMPLE GAMMA SEARCH
   7 C
   8         dimension mg(*),eg(*)
   9         common /error/ier
  10         include 'comwlgen.for'
  11         include 'comalwl.for'
  12         include 'comgam.for'
  13
  14         dimension e3na3(3,3),ijdd(2)
  15
  16         data kgmax /1000/
  17
  18         IF(NG.EQ.0) RETURN
  19         DO 1 N=1,NG
  20         EM=EG(N)
  21
  22         M=MG(N)
  23         IF(EM.LT.GLTHR) GOTO 1
  24 c        IF(EM.LT.GmTHR(m)) GOTO 1
  25         if(iflgmthr.eq.0) then
  26         iflgmthr=1
  27 c       write (*,*) ' Warning !! no glass thresholds now !'
  28         endif
  29
  30 c piks search
  31         call findpik(m,iokpik,e3na3,ff)
  32
  33
  34
  35         if(iokpik.eq.0) goto 1
  36
  37         ijdd(1)=1
  38         ijdd(2)=1
  39         if(e3na3(1,2).gt.e3na3(3,2)) ijdd(1)=-1
  40         if(e3na3(2,1).gt.e3na3(2,3)) ijdd(2)=-1
  41
  42 c new gamma
  43           IF(KG.GT.kgmax) THEN
  44             IER=32
  45             RETURN
  46           ENDIF
  47
  48         xx=X(1,M)
  49         yy=x(2,M)
  50         ee=WL(M)
  51         see=ee/4.
  52         sxx=d(1,m)/2.
  53         syy=d(2,m)/2.
  54         call adgmnew(m,ee,xx,yy,see,sxx,syy,ijdd)
  55
  56 1       CONTINUE
  57
  58         RETURN
  59         END
  60
  61         subroutine savegm
  62
  63         include 'comgam.for'
  64         COMMON /SVGAMMA/KGsv,MWsv(ngp),IDsv(ngp),JDsv(ngp),svE(ngp),
  65      ,  svE4(ngp),
  66      ,  svXW(ngp),svYW(ngp),svES(nsps,ngp),svET(nsps,ngp),
  67      ,  ISsdsv(ngp),
  68      ,  IGDEVsv(ngp),svZGDEV(ngp),svsigexy(3,ngp),
  69      ,  svEmimx(2,nsps,ngp),
  70      ,  kgfixsv,svigfix(ngp),svcgfix(3,ngp),svsgfix(3,ngp),
  71      ,  svhiw(ngp),
  72      ,  svwsw(nsps,ngp),svh1w(ngp),svh0w(ngp)
  73
  74         if(kg.eq.0) return
  75
  76                 do k=1,kg
  77                 mwsv(kgsv+k)=mw(k)
  78                 idsv(kgsv+k)=id(k)
  79                 jdsv(kgsv+k)=jd(k)
  80                 sve(kgsv+k)=e(k)
  81                 sve4(kgsv+k)=e4(k)
  82                 svxw(kgsv+k)=xw(k)
  83                 svyw(kgsv+k)=yw(k)
  84
  85                 do kn=1,nsps
  86                         sves(kn,kgsv+k)=es(kn,k)
  87                         svet(kn,kgsv+k)=et(kn,k)
  88                         svemimx(1,kn,kgsv+k)=emimx(1,kn,k)
  89                         svemimx(2,kn,kgsv+k)=emimx(2,kn,k)
  90                         svwsw(kn,kgsv+k)=wsw(kn,k)
  91                 enddo
  92                 issdsv(kgsv+k)=issd(k)
  93                 igdevsv(kgsv+k)=igdev(k)
  94                 svzgdev(kgsv+k)=zgdev(k)
  95                 call ucopy(sigexy(1,k),svsigexy(1,kgsv+k),3)
  96                 enddo
  97                 kgsv=kgsv+kg
  98         return
  99
 100         entry zsavegm
 101                 kgsv=0
 102         return
 103
 104         entry unsavegm
 105                 kg=kgsv
 106                 do k=1,kgsv
 107                 mw(k)=mwsv(k)
 108                 id(k)=idsv(k)
 109                 jd(k)=jdsv(k)
 110                 e(k)=sve(k)
 111                 e4(k)=sve4(k)
 112                 xw(k)=svxw(k)
 113                 yw(k)=svyw(k)
 114
 115                 do kn=1,nsps
 116                         es(kn,k)=sves(kn,k)
 117                         et(kn,k)=svet(kn,k)
 118                         emimx(1,kn,k)=svemimx(1,kn,k)
 119                         emimx(2,kn,k)=svemimx(2,kn,k)
 120                         wsw(kn,k)=svwsw(kn,k)
 121                 enddo
 122                 issd(k)=issdsv(k)
 123                 igdev(k)=igdevsv(k)
 124                 zgdev(k)=svzgdev(k)
 125                 call ucopy(sigexy(1,k),svsigexy(1,k),3)
 126                 enddo
 127         return
 128         end
 129         SUBROUTINE findpik(m,iokpik,e3na3,ffls)
 130
 131         common /error/ier
 132         include 'comwlgen.for'
 133         include 'comalwl.for'
 134         include 'comgam.for'
 135
 136         real e3na3(3,3)
 137
 138
 139
 140         ff=ffls
 141         if(ffls.le.0.) ff=1.
 142         em=wl(m)
 143
 144 c ALL arround less then em
 145 c       do k=2,ns(m)
 146 c       ms=ks(k,m)
 147 c       if(em.lt.wl(ms)) goto 1
 148 c       enddo
 149
 150         call vzero(e3na3,9)
 151
 152         IF(NKS(M).EQ.0) THEN
 153 c simple case
 154           ILS=KS(2,M)
 155           IF(EM.LE.WL(ILS)) GOTO 1
 156           EL=WL(ILS)
 157           IRS=KS(3,M)
 158           IF(EM.LT.WL(IRS)) GOTO 1
 159           ER=WL(IRS)
 160           IUS=KS(4,M)
 161           IF(EM.LT.WL(IUS)) GOTO 1
 162           EU=WL(IUS)
 163           IDS=KS(5,M)
 164           IF(EM.LE.WL(IDS)) GOTO 1
 165           ED=WL(IDS)
 166 c L-sosedi
 167           ILUS=KS(6,M)
 168           IF(EM.LE.WL(ILS)/ff) GOTO 1
 169           ELU=WL(ILUS)
 170           IRUS=KS(7,M)
 171           IF(EM.LT.WL(IRUS)/ff) GOTO 1
 172           ERU=WL(IRUS)
 173           ILDS=KS(8,M)
 174           IF(EM.LT.WL(ILDS)/ff) GOTO 1
 175           ELD=WL(ILDS)
 176           IRDS=KS(9,M)
 177           IF(EM.LE.WL(IRDS)/ff) GOTO 1
 178           ERD=WL(IRDS)
 179
 180
 181 c new gamma in standart case
 182          ELSE
 183 c complex case
 184           NLS=IBITS(NKS(M),0,2)
 185           NRS=IBITS(NKS(M),2,2)
 186           NUS=IBITS(NKS(M),4,2)
 187           NDS=IBITS(NKS(M),6,2)
 188           NLUS=IBITS(NKS(M),8,1)
 189           NRUS=IBITS(NKS(M),9,1)
 190           NLDS=IBITS(NKS(M),10,1)
 191           NRDS=IBITS(NKS(M),11,1)
 192           L=1
 193           EL=0.
 194           DO K=1,NLS
 195           L=L+1
 196           ILS=KS(L,M)
 197           IF(EM.LE.WL(ILS)) GOTO 1
 198           EL=EL+WL(ILS)
 199           ENDDO
 200           ER=0.
 201           DO K=1,NRS
 202           L=L+1
 203           IRS=KS(L,M)
 204           IF(EM.LT.WL(IRS)) GOTO 1
 205           ER=ER+WL(IRS)
 206           ENDDO
 207           EU=0.
 208           DO K=1,NUS
 209           L=L+1
 210           IUS=KS(L,M)
 211           IF(EM.LE.WL(IUS)) GOTO 1
 212           EU=EU+WL(IUS)
 213           ENDDO
 214           ED=0.
 215           DO K=1,NDS
 216           L=L+1
 217           IDS=KS(L,M)
 218           IF(EM.LE.WL(IDS)) GOTO 1
 219           ED=ED+WL(IDS)
 220           ENDDO
 221 c L-sosedi
 222           ELU=0.
 223           DO K=1,NLUS
 224           L=L+1
 225           ILUS=KS(L,M)
 226           IF(EM.LE.WL(ILUS)/ff) GOTO 1
 227           ELU=ELU+WL(ILUS)
 228           ENDDO
 229           ERU=0.
 230           DO K=1,NRUS
 231           L=L+1
 232           IRUS=KS(L,M)
 233           IF(EM.LT.WL(IRUS)/ff) GOTO 1
 234           ERU=ERU+WL(IRUS)
 235           ENDDO
 236           ELD=0.
 237           DO K=1,NLDS
 238           L=L+1
 239           ILDS=KS(L,M)
 240           IF(EM.LE.WL(ILDS)/ff) GOTO 1
 241           ELD=ELD+WL(ILDS)
 242           ENDDO
 243           ERD=0.
 244           DO K=1,NRDS
 245           L=L+1
 246           IRDS=KS(L,M)
 247           IF(EM.LE.WL(IRDS)/ff) GOTO 1
 248           ERD=ERD+WL(IRDS)
 249           ENDDO
 250 c end of both cases
 251         ENDIF
 252
 253         e3na3(2,2)=em
 254         e3na3(1,2)=el
 255         e3na3(3,2)=er
 256         e3na3(2,1)=ed
 257         e3na3(2,3)=eu
 258         e3na3(1,3)=elu
 259         e3na3(3,3)=eru
 260         e3na3(1,1)=eld
 261         e3na3(3,1)=erd
 262
 263         iokpik=1
 264         return
 265
 266 1       iokpik=0
 267         RETURN
 268         END
 269 c
 270         subroutine adgmnew(m,ee,xx,yy,see,sxx,syy,ijdd)
 271         common /error/ier
 272         include 'comwlgen.for'
 273         include 'comalwl.for'
 274         include 'comgam.for'
 275
 276         dimension ijdd(2)
 277
 278         kg=kg+1
 279         mw(kg)=m
 280         id(kg)=ijdd(1)
 281         jd(kg)=ijdd(2)
 282 c set wall marker to gamma
 283         igdev(kg)=0
 284         do iw=1,nwall
 285         if(m.gt.madwl(iw).and.m.le.madwl(iw+1)) then
 286                 igdev(kg)=iw
 287                 goto 555
 288         endif
 289         enddo
 290 555     continue
 291 c gamma coord och. grubo
 292         XW(KG)=xx
 293         YW(KG)=yy
 294         E(KG)=ee
 295         zgdev(kg)=zmidlshower(ee,m)
 296         sigexy(1,kg)=see
 297         sigexy(2,kg)=sxx
 298         sigexy(3,kg)=syy
 299         DO K=1,NS(M)
 300         LS=KS(K,M)
 301         ES(K,KG)=WL(LS)
 302         ENDDO
 303         call filraxay(kg)
 304 c end new gamma
 305         return
 306         end
 307 C
 308         subroutine filraxay(k)
 309         include 'comalwl.for'
 310         include 'comgam.for'
 311         include 'comwlgen.for'
 312
 313         data ifl/0/
 314         if(ifl.eq.0) then
 315 c        write (*,*) ' FILRAXAY WARNING dz=4600. eto SMESHNO !!! '
 316         ifl=1
 317         endif
 318
 319         dz=4600.
 320 c       dz=xyzwall(3,iw)-xyzvtx(3)
 321
 322         m=mw(k)
 323
 324         raxay(1,k)=xw(k)
 325         raxay(2,k)=yw(k)
 326         raxay(3,k)=zgdev(k)
 327 c       raxay(3,k)=46.
 328         raxay(4,k)=-x(1,m)/dz
 329         raxay(5,k)=-x(2,m)/dz
 330 c       raxay(4,k)=xw(k)/dz
 331 c       raxay(5,k)=yw(k)/dz
 332
 333         return
 334         end
 335
 336         SUBROUTINE FILWT0
 337         include 'comalwl.for'
 338         include 'comgam.for'
 339
 340         common /comdevpar/sigmaph,sigmapd,sigphsq,sigpdsq
 341         data ifl/0/
 342 c       write (*,*) ' filwt0 '
 343
 344         if(ifl.eq.0) then
 345                 do n=1,nt
 346                 swlt0(n)=sigpdsq
 347                 enddo
 348         write (*,*) ' filwt0 OK  !!! '
 349         ifl=1
 350         else
 351          write (*,*) ' filwt0 ne nado !!! '
 352
 353         endif
 354
 355         return
 356         end
 357
 358         SUBROUTINE FILWT
 359         include 'comalwl.for'
 360         include 'comgam.for'
 361
 362         common /comdevpar/sigmaph,sigmapd,sigphsq,sigpdsq
 363         data ifl/0/
 364 C
 365
 366 c       write (*,*) ' filwt '
 367
 368         if(ifl.eq.0) then
 369         sigmaped=0.01
 370
 371 c        call filwt0
 372         ifl=1
 373         endif
 374
 375
 376         IF(KG.EQ.0) RETURN
 377         DO K=1,KG
 378         M=MW(K)
 379
 380         DO N=1,NS(M)
 381         MS=KS(N,M)
 382         WLT(MS)=WLT(MS)+ET(N,K)
 383 c       swlt(ms)=swlt(ms)+(emimx(2,n,k)-emimx(1,n,k))**2/4.
 384         swlt(ms)=swlt(ms)+dispeces(n,k)
 385         ENDDO
 386         ENDDO
 387
 388         RETURN
 389         END
 390 C
 391         SUBROUTINE CLRWT
 392         include 'comalwl.for'
 393         include 'comgam.for'
 394 C
 395         IF(KG.EQ.0) RETURN
 396         DO K=1,KG
 397         M=MW(K)
 398
 399         DO N=1,NS(M)
 400         MS=KS(N,M)
 401         WLT(MS)=0.
 402         SWLT(MS)=0.
 403         swltmx(ms)=0.
 404         ENDDO
 405         ENDDO
 406
 407         call vzero(wlt,nt)
 408
 409         RETURN
 410         END
 411 C
 412
 413         SUBROUTINE DIVEN
 414
 415         include 'comalwl.for'
 416         include 'comgam.for'
 417
 418         IF(KG.LE.1) RETURN
 419         DO K=1,KG
 420         h1w(k)=0.
 421         h0w(k)=0.
 422         MK=MW(K)
 423           DO N=1,NS(MK)
 424           MN=KS(N,MK)
 425                   ES(N,K)=WL(MN)*ET(N,K)/WLT(MN)
 426           ENDDO
 427
 428         ENDDO
 429
 430         RETURN
 431         END
 432
 433         subroutine simplfite0
 434         include 'comalwl.for'
 435         include 'comgam.for'
 436         do k=1,kg
 437         mk=mw(k)
 438         sum1=0.
 439         sum2=0.
 440         do n=1,ns(mk)
 441         ms=ks(n,mk)
 442         en=et(n,k)/e(k)
 443         disp=swlt(ms)
 444         sum1=sum1+es(n,k)*en/disp
 445         sum2=sum2+en*en/disp
 446         enddo
 447         enew=sum1/sum2
 448 c        write (*,*) ' k, e_old, e_new ',k,e(k),enew
 449         enddo
 450         return
 451         end
 452
 453
 454         SUBROUTINE ECGAM
 455 C
 456 C K+  12.90  KOLOSOV V.N.
 457 C     14.03.92
 458 C             E,X,Y   GAMMA CALCULATION
 459 C
 460         include 'comalwl.for'
 461         include 'comgam.for'
 462         COMMON /COORF/CFUN(200)
 463         DIMENSION EEE(9),NNN(9),KEY(3,3)
 464         DATA KEY  /   8,5,9,
 465      ,                2,1,3,
 466      ,                6,4,7/
 467 C
 468         IF(KG.EQ.0) RETURN
 469         DO 1 N=1,KG
 470         M=MW(N)
 471         IF(NKS(M).EQ.0) THEN
 472           DO I=1,9
 473           EEE(I)=ES(I,N)
 474           ENDDO
 475          ELSE
 476           NNN(1)=1
 477           NNN(2)=IBITS(NKS(M),0,2)
 478           NNN(3)=IBITS(NKS(M),2,2)
 479           NNN(4)=IBITS(NKS(M),4,2)
 480           NNN(5)=IBITS(NKS(M),6,2)
 481           NNN(6)=IBITS(NKS(M),8,1)
 482           NNN(7)=IBITS(NKS(M),9,1)
 483           NNN(8)=IBITS(NKS(M),10,1)
 484           NNN(9)=IBITS(NKS(M),11,1)
 485           L=1
 486           DO I=1,9
 487           EEE(I)=0.
 488           DO K=1,NNN(I)
 489           EEE(I)=EEE(I)+ES(L,N)
 490           L=L+1
 491           ENDDO
 492           ENDDO
 493         ENDIF
 494 C
 495         E(N)=0.
 496         DO K=1,9
 497         E(N)=E(N)+EEE(K)
 498         ENDDO
 499         E4(N)=0.
 500 C
 501         DO I=2,2+ID(N),ID(N)
 502         DO J=2,2+JD(N),JD(N)
 503         K=KEY(I,J)
 504         E4(N)=E4(N)+EEE(K)
 505         ENDDO
 506         ENDDO
 507
 508         IF(ID(N).EQ.1) THEN
 509           IL=2
 510          ELSE
 511           IL=1
 512         ENDIF
 513
 514         IF(JD(N).EQ.1) THEN
 515           JL=2
 516          ELSE
 517           JL=1
 518         ENDIF
 519
 520         EL=0.
 521         DO J=2,2+JD(N),JD(N)
 522         K=KEY(IL,J)
 523         EL=EL+EEE(K)
 524         ENDDO
 525
 526         ED=0.
 527         DO I=2,2+ID(N),ID(N)
 528         K=KEY(I,JL)
 529         ED=ED+EEE(K)
 530         ENDDO
 531         if(el.eq.0.and.ed.eq.0) then
 532                 write (*,*) ' ECGAM giagnostic EG=0 '
 533                 write(*,*) ' KG,ng,id,jd ',kg,n,id(n),jd(n)
 534                 write(*,*) ' egam',(es(i,n),i=1,9)
 535         endif
 536         DHx=D(1,M)/2.
 537         DHy=D(2,M)/2.
 538
 539         X0=X(1,M)+ID(N)*DHx
 540         Y0=x(2,M)+JD(N)*DHy
 541
 542         ax=raxay(4,n)
 543         ay=raxay(5,n)
 544
 545 c        write (*,*) ' ax,ay ',ax,ay
 546         xx=coornew(el,e4(n)-el,ax,m)
 547         yy=coornew(ed,e4(n)-ed,ay,m)
 548
 549 c        write (*,*) ' xx,yy ',xx,yy
 550 c put cell center if too far
 551         IF(XX.LT.-DHx) XX=-DHx
 552         IF(XX.GT. DHx) XX= DHx
 553         IF(YY.LT.-DHy) YY=-DHy
 554         IF(YY.GT. DHy) YY= DHy
 555
 556
 557         XW(N)=X0+XX
 558         YW(N)=Y0+YY
 559
 560         dxm=xw(n)-x(1,mw(n))
 561         if(ax.le.0.) then
 562         xxc=dxm
 563         corr=1.076+0.163*xxc-0.00955*xxc**2-0.0013215*xxc**3
 564         else
 565         xxc=-dxm
 566         corr=1.076+0.163*xxc-0.00955*xxc**2-0.0013215*xxc**3
 567         corr=-corr
 568         endif
 569         xw(n)=xw(n)-corr
 570
 571         dxm=yw(n)-x(2,mw(n))
 572         if(ay.le.0.) then
 573         xxc=dxm
 574         corr=1.076+0.163*xxc-0.00955*xxc**2-0.0013215*xxc**3
 575         else
 576         xxc=-dxm
 577         corr=1.076+0.163*xxc-0.00955*xxc**2-0.0013215*xxc**3
 578         corr=-corr
 579         endif
 580         yw(n)=yw(n)-corr
 581
 582
 583         call filraxay(n)
 584 1       CONTINUE
 585
 586 c        call simplfite0
 587         call betterthanfit
 588
 589
 590         RETURN
 591         END
 592
 593         subroutine betterthanfit
 594         include 'comalwl.for'
 595         include 'comgam.for'
 596         include 'comgl.for'
 597         include 'comwlgen.for'
 598 c ADD energy out 3*3 cells for crystalls only
 599         do k=1,kg
 600         e(k)=1.065*e(k)
 601         dxm=xw(k)-x(1,mw(k))
 602         dym=yw(k)-x(2,mw(k))
 603         rm=sqrt(dxm**2+dym**2)
 604         e(k)=e(k)*(1.+0.01*rm/15.)
 605         ee=e(k)
 606         e(k)=ee*(1.+0.03*exp(-ee))
 607         enddo
 608         return
 609         end
 610
 611         subroutine filet
 612         include 'comalwl.for'
 613         include 'comgam.for'
 614         common /comdevpar/sigmaph,sigmapd,sigphsq,sigpdsq
 615         real rxxyy(5)
 616
 617         if(kg.eq.0) return
 618
 619         do k=1,kg
 620         m=mw(k)
 621
 622         xg=xw(k)
 623         yg=yw(k)
 624
 625         do n=1,ns(m)
 626         ms=ks(n,m)
 627         xs=x(1,ms)
 628         ys=x(2,ms)
 629
 630         et(n,k)=e(k)*ampcelnew(e(k),raxay(1,k),x(1,ms),d(1,ms),ms)
 631
 632         if(et(n,k).le.0) then
 633
 634                 write (*,*) ' et=0!! kg,k,m,n,e(k) ',kg,k,m,n,e(k)
 635                 et(n,k)=e(k)*0.0001
 636         endif
 637
 638         emimx(1,n,k)=et(n,k)
 639         emimx(2,n,k)=et(n,k)
 640
 641         dispeces(n,k)=
 642      =  (sigwlgam0(et(n,k),e(k)))**2+sigmphsq*et(n,k)
 643
 644         sigmaes0(n,k)=sqrt(dispeces(n,k))
 645
 646         enddo
 647
 648         enddo
 649
 650         RETURN
 651         END
 652
 653         subroutine killgm(kkg)
 654
 655         common /error/ier
 656         include 'comgam.for'
 657         include 'comalwl.for'
 658
 659         M=MW(Kkg)
 660
 661
 662         if(kkg.eq.kg) then
 663                 kg=kg-1
 664         else
 665                 kg=kg-1
 666                 do k=kkg,kg
 667                 mw(k)=mw(k+1)
 668                 id(k)=id(k+1)
 669                 jd(k)=jd(k+1)
 670                 e(k)=e(k+1)
 671                 e4(k)=e4(k+1)
 672                 xw(k)=xw(k+1)
 673                 yw(k)=yw(k+1)
 674
 675                 do kn=1,nsps
 676                         es(kn,k)=es(kn,k+1)
 677                         et(kn,k)=et(kn,k+1)
 678                         emimx(1,kn,k)=emimx(1,kn,k+1)
 679                         emimx(2,kn,k)=emimx(2,kn,k+1)
 680                         wsw(kn,k)=wsw(kn,k+1)
 681                 enddo
 682                 issd(k)=issd(k+1)
 683                 igdev(k)=igdev(k+1)
 684                 zgdev(k)=zgdev(k+1)
 685                 call ucopy(sigexy(1,k+1),sigexy(1,k),3)
 686                 call ucopy(raxay(1,k+1),raxay(1,k),5)
 687                 enddo
 688         endif
 689         return
 690         end
 691
 692         subroutine concatgm(k1,k2)
 693
 694         common /error/ier
 695         include 'comgam.for'
 696         include 'comalwl.for'
 697
 698         if(k1.gt.kg.or.k1.le.0) return
 699         if(k2.gt.kg.or.k2.le.0) return
 700         enew=e(k1)+e(k2)
 701         xnew=(xw(k1)*e(k1)+xw(k2)*e(k2))/enew
 702         ynew=(yw(k1)*e(k1)+yw(k2)*e(k2))/enew
 703         e(k2)=enew
 704         xw(k2)=xnew
 705         yw(k2)=ynew
 706         raxay(1,k2)=xnew
 707         raxay(2,k2)=ynew
 708         id(k2)=1
 709         jd(k2)=1
 710         if(xnew.lt.x(1,mw(k2))) id(k2)=-1
 711         if(ynew.lt.x(2,mw(k2))) jd(k2)=-1
 712
 713         call killgm(k1)
 714
 715         call filet
 716         call filwt
 717         call diven
 718         call ecgam
 719         call clrwt
 720
 721         return
 722         end
 723
 724
 725