1 REAL*8 FUNCTION vbfdistr(ID1,ID2,ID3,ID4,HH1,HH2,PP,KEYIN)
17 INTEGER I1,I2,I3,I4,ID1,ID2,ID3,ID4,H1,H2,HH1,HH2,BUF_H,KEY,KEYIN
18 REAL*8 P(0:3,6), PP(0:3,6),ANS
22 INTEGER BUF_I,IGLU,I,J,K
25 DATA initialized/.false./
27 LOGICAL FLIPER,TESTUJEMY
30 testujemy=id1.eq.-222.and.id2.eq.1.and.id3.eq.-1.and.id4.eq.1
33 IF(.NOT.initialized)
THEN 38 IF (keyin.NE.keystored)
THEN 39 CALL vbf_reinit(keyin)
45 WRITE(*,*)
'non-standard state -- implementation not finished' 47 ELSE IF(key.NE.0.AND.key.NE.1)
THEN 48 WRITE(*,*)
'WRONG KEY' 55 IF (testujemy)
WRITE(*,*)
'idsy=',id1,id2,id3,id4
63 IF(i1+i2.EQ.42.AND.i3+i4.EQ.0)
THEN 65 ELSEIF(i3+i4.EQ.42.AND.i1+i2.EQ.0)
THEN 67 ELSEIF(i1*i2*i3*i4.LT.0)
THEN 72 IF(mod(i1+i2+i3+i4,2).EQ.1)
THEN 77 IF(i1.LT.0.and.i2.LT.0.AND.(i3.GT.0.OR.i4.GT.0))
THEN 82 IF(i3.LT.0.and.i4.LT.0.AND.(i1.GT.0.OR.i2.GT.0))
THEN 90 IF(sign(mod(i1,2),i1)+sign(mod(i2,2),i2).NE.sign(mod(i3,2),i3)+sign
THEN 91 IF(i1+i2+i3+i4.LT.20)
THEN 101 IF(i1.EQ.21) iglu=iglu+1
102 IF(i2.EQ.21) iglu=iglu+1
103 IF(i3.EQ.21) iglu=iglu+1
104 IF(i4.EQ.21) iglu=iglu+1
107 IF(iglu.EQ.1.OR.iglu.GT.2)
THEN 115 IF(iglu.EQ.2.AND.i1+i2.NE.i3+i4)
THEN 117 IF(.NOT.(i1+i2.EQ.0.OR.i3+i4.EQ.0))
THEN 151 IF((i1*i1.EQ.25.OR.i2*i2.EQ.25.OR.i3*i3.EQ.25.OR.i4*i4.EQ.25))
THEN 159 if(testujemy)
write(*,*)
'doszlimy do stepX',i1,i2, i3, i4
163 IF(i1*i2.LT.0.AND.i1+i2.LT.11.AND.i1**2.LT.i2**2)
THEN 176 if(testujemy)
write(*,*)
'doszlimy do step2',i1,i2, i3, i4
182 $ (i1.LT.0.OR.i1.EQ.21).AND.
183 $ (i2.LT.0.OR.i2.EQ.21).AND.
184 $ (i3.LT.0.OR.i3.EQ.21).AND.
185 $ (i4.LT.0.OR.i4.EQ.21) )
THEN 213 fliper=(i1*i2.LT.0.AND.i1+i2.LT.11)
215 fliper=i2*i2.GT.i1*i1
216 IF(id1*id2.EQ.-2.AND.(id1.EQ.1.OR.id1.EQ.-2)) fliper=.NOT.fliper
242 if(testujemy)
write(*,*)
'doszlimy do step3',i1,i2,i3,i4
246 IF(i1.LT.0.OR.(i2.EQ.21.AND.i1.NE.21))
THEN 260 IF(i1.GT.0.AND.i2.GT.0.AND.i1+i2.LT.11.AND.i1.LT.i2)
THEN 278 IF(i3.LT.0.OR.(i4.EQ.21.AND.i3.NE.21))
THEN 292 IF(mod(i3,2).EQ.1.AND.mod(i4,2).EQ.0.AND.i3*i4.GT.0.AND.i3.NE.21)
THEN 307 IF(mod(i3,2).EQ.1.AND.mod(i4,2).EQ.1.AND.i3*i4.GT.0.AND.i3.GT.i4.AND.i3.NE.
THEN 322 IF(mod(i3,2).EQ.0.AND.mod(i4,2).EQ.0.AND.i3*i4.GT.0.AND.i3.GT.i4)
THEN 335 if(testujemy)
write(*,*)
'doszlimy do case-a ',i1,i2,i3,i4
345 if(testujemy)
write(*,*)
'doszlimy do 0 case-a ',i1,i2,i3,i4
346 IF(abs(i1).EQ.1)
CALL ddx(p,i3,i4,h1,h2,key,ans)
347 IF(abs(i1).EQ.2)
CALL uux(p,i3,i4,h1,h2,key,ans)
348 IF(abs(i1).EQ.3)
CALL ssx(p,i3,i4,h1,h2,key,ans)
349 IF(abs(i1).EQ.4)
CALL ccx(p,i3,i4,h1,h2,key,ans)
350 if(testujemy)
write(*,*)
'doszlimy do 0 case-a ',i1,i2,i3,i4,ans
352 IF(abs(i1).EQ.2)
CALL udx(p,i3,i4,h1,h2,key,ans)
353 IF(abs(i1).EQ.4)
CALL csx(p,i3,i4,h1,h2,key,ans)
354 IF(abs(i1).EQ.3)
CALL sux(p,i3,i4,h1,h2,key,ans)
356 if(testujemy)
write(*,*)
'doszlimy do 2 case-a ',i1,i2,i3,i4
357 IF(abs(i1).EQ.1)
CALL dd(p,i3,i4,h1,h2,key,ans)
358 IF(abs(i1).EQ.4)
CALL cux(p,i3,i4,h1,h2,key,ans)
359 IF(abs(i1).EQ.3)
CALL sdx(p,i3,i4,h1,h2,key,ans)
361 IF(abs(i1).EQ.2)
CALL ud(p,i3,i4,h1,h2,key,ans)
362 IF(abs(i1).EQ.4)
CALL cdx(p,i3,i4,h1,h2,key,ans)
364 if(testujemy)
write(*,*)
'doszlimy do 4 case-a ',i1,i2,i3,i4
365 IF(abs(i1).EQ.2)
CALL uu(p,i3,i4,h1,h2,key,ans)
366 IF(abs(i1).EQ.1)
CALL ds(p,i3,i4,h1,h2,key,ans)
367 IF(abs(i1).EQ.3)
CALL sd(p,i3,i4,h1,h2,key,ans)
369 CALL gd(p,i3,i4,h1,h2,key,ans)
371 CALL gu(p,i3,i4,h1,h2,key,ans)
373 CALL gd(p,i3,i4,h1,h2,key,ans)
375 CALL gu(p,i3,i4,h1,h2,key,ans)
377 CALL gd(p,i3,i4,h1,h2,key,ans)
379 CALL gg(p,i3,i4,h1,h2,key,ans)
381 CALL cc(p,i3,i4,h1,h2,key,ans)
383 CALL cs(p,i3,i4,h1,h2,key,ans)
385 IF(abs(i1).EQ.1)
CALL dc(p,i3,i4,h1,h2,key,ans)
386 IF(abs(i1).EQ.4)
CALL cd(p,i3,i4,h1,h2,key,ans)
387 IF(abs(i1).EQ.3)
CALL su(p,i3,i4,h1,h2,key,ans)
388 IF(abs(i1).EQ.2)
CALL us(p,i3,i4,h1,h2,key,ans)
390 if(testujemy)
write(*,*)
'doszlismy do cu i1,i2=',i1,i2,i3,i4
391 IF(abs(i1).EQ.3)
CALL ss(p,i3,i4,h1,h2,key,ans)
392 IF(abs(i1).EQ.4)
CALL cu(p,i3,i4,h1,h2,key,ans)
394 if(testujemy)
write(*,*)
'doszlimy do -2 case-a ',i1,i2,i3,i4
395 IF(abs(i1).EQ.2)
CALL ucx(p,i3,i4,h1,h2,key,ans)
396 IF(abs(i1).EQ.1)
CALL dsx(p,i3,i4,h1,h2,key,ans)
398 if(testujemy)
write(*,*)
'doszlimy do -1 case-a ',i1,i2,i3,i4
399 IF(abs(i1).EQ.2)
CALL usx(p,i3,i4,h1,h2,key,ans)
400 IF(abs(i1).EQ.3)
CALL scx(p,i3,i4,h1,h2,key,ans)
402 if(testujemy)
write(*,*)
'doszlimy do -3 case-a ',i1,i2,i3,i4
403 CALL dcx(p,i3,i4,h1,h2,key,ans)
408 IF(i3.NE.i4) ans=ans/2.d0
412 END FUNCTION vbfdistr