difh23b/lec1BRf
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*4 TRP,SPO
CHARACTER*4 ETAT
CHARACTER*50 fichier
character*80 t80
dimension trp(100,2000),eve(100),evfq(2000)
1,spo(100,5),t80(80)
c fichier='print'
fichier='zip2.herab:print'
open(7,file=fichier,status='NEW')
c fichier='Qcontj06'
c fichier='Pcontj00'
c fichier='zip2.herab:difh21:Qcontj06'
fichier='zip2.herab:difh21:Pcontj00'
write(7,*) fichier
open(31,file=fichier,status='old')
ilec=31
63 FORMAT(80A1)
do 1 iet=1,2
call lcontQ(ilec,ibe,ibf,iefin,iffiq,evfq,etat
1,eve,spo,trp,100,2000)
write(7,*)etat
write(7,*) 'ibe,ibf,iefin,iffip,iffir '
write(7,*) ibe,ibf,iefin,iffip,iffir
write(7,*) 'upper state energy level from H1S+H2S'
write(9,*) 'ibe,iefin,iffip,iffir,'
write(9,*) ibe,iefin,iffip,iffir
write(9,*) 'upper state energy level from H1S+H2S'
write(7,370) (eve(ie),ie=1,iefin)
write(9,370) (eve(ie),ie=1,iefin)
370 FORMAT(1X,4(1X,F15.5))
DO 5 I=1,2
write(7,*) 'proportion of state ',I
write(7,37)(SPO(IE,I),IE=1,IEFIN)
write(9,*) 'proportion of state ',I
write(9,37)(SPO(IE,I),IE=1,IEFIN)
5 CONTINUE
37 FORMAT(1X,5E13.6)
ie=5
nvu=ie-1
nju=ibe-1
njf=ibf-1
write(7,*) 'dissociative emission from ', etat
1 ,' v=',nvu,' J=',nju
write(7,*) 'if,K.E.,A '
do 2 if=1,50
write(7,371) if,evfq(if),trp(ie,if)
371 format(1x,I5,1x,F15.5,2(1x,e13.6))
2 continue
if50=iffiq-50
do 3 if=if50,iffiq
write(7,371) if,evfq(if),trp(ie,if)
3 continue
1 continue
stop
end
c/////////////////////////////////////////////////
SUBROUTINE lcontQ(LIWRI,IBE,IBF,IEFIN,IFFIQ,evfq
1,ETAT,EVE,SPO,TRP,IDIVE,IDIVF)
IMPLICIT DOUBLE PRECISION (A-H,O-Z)
REAL*4 TRP,SPO
CHARACTER*4 ETAT,ETA1,ETA2
CHARACTER*1 T80
DIMENSION EVE(IDIVE),TRP(IDIVE,IDIVF),SPO(IDIVE,5),IM1(100)
1 ,evfq(idivf),T80(80)
c PRINT *, 'IDIVE,IDIVF',IDIVE,IDIVF
DO 120 IDE=1,IDIVE
EVE(IDE)=0.D0
DO 121 IS=1,5
121 SPO(IDE,IS)=0.
DO 120 IDF=1,IDIVF
TRP(IDE,IDF)=0.
120 CONTINUE
C PRINT *, 'LWBCQ4 LIWRI 2 ',LIWRI
READ(LIWRI, 40)IBE,IBF,IEFIN,IFFIQ,ETAT,ETA1,ETA2
WRITE(7, 40)IBE,IBF,IEFIN,IFFIQ,ETAT,ETA1,ETA2
38 FORMAT(1X,10I7)
40 FORMAT(1X,4I10,3A4,D16.9)
c WRITE(6, 199)ETAT
DO 30 IA=1,2
READ(LIWRI,45)T80
c PRINT 46,T80
30 CONTINUE
45 FORMAT(80A1)
46 FORMAT(1X,80A1)
199 FORMAT(1X,'E STATE HAS LABEL ',1A4)
IEMIN=1
IFMIN=1
DO 3 I=1,100
IM1(I)=I-1
3 CONTINUE
IBEM1=IBE-1
C WRITE(6, 202)IBEM1
202 FORMAT(1X,'VIBRATIONAL LEVELS FOR STATE E IN 1/CM FOR J=',I3)
READ(LIWRI, 370)(EVE(IE),IE=IEMIN,IEFIN)
370 FORMAT(1X,4(1X,F15.5))
READ(LIWRI,45)T80
c PRINT 46,T80
C WRITE(6, 2041)ETA1
C2041 FORMAT(1X,'PROPORTION OF STATE ',1A4)
READ(LIWRI, 37)(SPO(IE,1),IE=1,IEFIN)
READ(LIWRI,45)T80
c PRINT 46,T80
C WRITE(6 , 2042)ETA2
C2042 FORMAT(1X,'PROPORTION OF STATE ',1A4)
READ(LIWRI, 37)(SPO(IE,2),IE=1,IEFIN)
C IBF=IBE
IFFIN=IFFIQ
IBEM1=IBE-1
IBFM1=IBF-1
c WRITE(6 , 200)IBEM1,IBFM1
200 FORMAT(1X,'TRANSITIONS BETWEEN STATE E(J=',I3,
1 ') AND STATE F(J=',I3,')')
4 FORMAT(//)
CPRI
CPRI WRITE(6 , 4)
37 FORMAT(1X,5E13.6)
READ(LIWRI,45)T80
C PRINT 46,T80
c WRITE(6 , 203)IBEM1,IBFM1
203 FORMAT(1X,'TABLE FOR EMISSION PROBABILITIES E(J=',I3,',IE) ==>
1F(J=',I3,',IF)')
DO 22 IET=1,20
IET1=IEMIN+4*(IET-1)
IF(IET1.GT.IEFIN) GO TO 223
IET2=min0(IEMIN+4*IET-1,IEFIN)
READ(LIWRI,45)T80
C PRINT 46,T80
C WRITE(6, 303)(IM1(IE),IE=IET1,IET2)
2 FORMAT(/)
303 FORMAT(9X,'IE==>',4(I7,6X))
DO 21 IF=IFMIN,IFFIN
READ(LIWRI,304) evfq(if),(TRP(IE,IF),IE=IET1,IET2)
C WRITE(6 ,304)IM1(IF),(TRP(IE,IF),IE=IET1,IET2)
c304 FORMAT (1X,'IF=',I3,7X,4E13.6)
304 FORMAT (1X,f11.2,1X,4E13.6)
305 FORMAT (1X,13X,4E13.6)
260 FORMAT(1X,A4)
21 CONTINUE
22 CONTINUE
223 CONTINUE
C WRITE(6, 4)
DO 111 I=1,3
READ(LIWRI,45)T80
C PRINT 45,T80
111 CONTINUE
1 CONTINUE
RETURN
END
CSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSSC
