Initial commit

1 files changed, 218 insertions, 0 deletions

diff --git a/width/inpwidth.for b/width/inpwidth.for
new file mode 100644
index 0000000..b7058c8
--- /dev/null
+++ b/width/inpwidth.for
@@ -0,0 +1,218 @@
+	program inpwidth
+	character*10 label,labelp,other1,other2
+	character*80 card,star,end,stop,mol1,mol2,hlin,begin
+	character*80 modfile,c,linefile
+	character*4 ref
+	character*5 modcard
+	dimension vts(3),angle(20)
+	data end/'END'/
+	data stop/'STOP'/
+	data mol1/'MOLECULES ON'/
+	data mol2/'READ MOLECULES'/
+	data hlin/'OPACITY ON HLINES'/
+	data begin/'BEGIN'/
+	data label/'          '/
+	data labelp/'          '/
+	data other1/'          '/
+	data other2/'          '/
+	nblo=0
+	npup=0
+	iso1=0
+	x1=0.
+	iso2=0
+	x2=0.
+	open(unit=2,file='inplines.dat',status='unknown')
+	open(unit=1,status='new')
+	open(unit=10,status='old',readonly,shared,recl=160)
+	open(unit=11,status='old',readonly,shared,recl=160)
+	open(unit=12,status='old',readonly,shared,recl=160)
+	open(unit=13,status='old',readonly,shared,recl=160)
+	open(unit=14,status='old',readonly,shared,recl=160)
+	open(unit=15,status='old',readonly,shared,recl=160)
+	open(unit=16,status='old',readonly,shared,recl=160)
+	open(unit=17,status='old',readonly,shared,recl=160)
+	open(unit=18,status='old',readonly,shared,recl=160)
+   	type 311
+311	format(3x,'star name  ',$)
+	accept 90,star
+	type 1
+1	format(3x,'VTUR(bulence)? (yes=1/no=0)  ',$)
+	accept*,iturb
+	if(iturb.eq.1) go to 10
+100	type 2
+2	format(3x,'PROF(ile)? (yes=1/no=0)   ',$)
+	accept*,iprof
+	if(iprof.eq.1) go to 20
+200	type 3
+3	format(3x,'AVER(age)? (yes=1/no=0)  ',$)
+	accept*, iaver
+	if (iaver.eq.1) go to 30
+300	type 4
+4	format(3x,'CURV(e)? (yes=1/no=0)   ',$)
+	accept*,icurv
+	if(icurv.eq.1) go to 40
+400	type 5
+5	format(3x,'end of data for the lines? (yes=1/no=0)  ',$)
+	accept*,iend
+	if(iend.eq.1) go to 500
+600	type 6
+6	format(3x,'stop ? (yes=1/no=0)  ',$)
+	accept*, istop
+	if(istop.eq.1) go to 60
+10	card='VTUR'
+	write (1,90) card
+90	format(a)
+	type 11
+11	format(3x,'Number N of the microturb. velocities (NMAX=3):  ',$)
+	accept*,nvt
+	type 12
+12	format(3x,'Type the values of the N microturb. velocities ',$)
+	accept*,(vts(ivt),ivt=1,nvt)
+	write(1,91) nvt,(vts(ivt),ivt=1,nvt)
+91	format(i5,3f5.2)
+	iwhat=1
+	type 14
+14	format(3x,'Is some line file already existing?(yes=1/no=0) ',$)
+	accept*,iold
+	if(iold.eq.0) go to 66
+ 667	read(2,190,end=66)card
+ 190	format(a4)
+	if(card.eq.'AVER')then
+	   write(1,190)card
+	   go to 667
+	   endif
+	if(card.eq.'LINE')then
+	read(2,874)wlobs
+	read(2,874)ew
+	write(1,9)card,ew,wlobs,star
+	read(2,874)gflog
+	read(2,911)ref
+	read(2,874)xj
+	read(2,8745)e
+	read(2,874)xjp
+	read(2,8745)ep
+	read(2,874)code
+ 8745	format(1x,f12.3)
+	wl=wlobs
+	write(1,444)wl,gflog,xj,e,xjp,ep,code,label,labelp
+	read(2,875)nelion
+	read(2,874)gammar
+	read(2,874)gammas
+	read(2,874)gammaw
+	read(2,873)alpha
+ 873	format(f6.3)
+	write(1,445)wl,nelion,gammar,gammas,gammaw,ref,nblo,nbup,iso1,
+	1 x1,iso2,x2,other1,other2,alpha
+	go to 667
+	endif
+66	type 13
+13	format(3x,'LINE ? (yes=1/no=0)   ',$)
+	accept*,iline
+	if(iline.eq.1) go to 50
+	if(iwhat.eq.3) GO TO 200
+	go to (100,200,300,400),iwhat
+20	card='PROF'
+	write(1,90) card
+	write(2,90)card
+	iwhat=2
+	go to 66
+30	card='AVER'
+	write(1,90) card
+	write(2,90)card
+	iwhat=3
+	go to 66
+40	card='CURV'
+	write(1,90) card
+	write(2,90)card
+	type 41
+41	format(3x,'type nablog,minlog,dablog'/3x,$)
+	accept*,nablog,fminlog,dablog
+	write(1,171) nablog,fminlog,dablog
+171	format(i5,2f8.2)
+	iwhat=4
+	go to 66
+ 50	card='LINE'
+	write(2,190)card
+	type 31
+31	format(3x,'wavelength (in Nm: es. 4000A=400.0 Nm):  ', $)
+	accept*,wlobs
+	write(2,874) wlobs
+874	format(1x,f10.4)
+	type 131
+131	format(3x,'equivalent width (in Pm: es. 200 mA=20.0 Pm):  ',$)
+	accept*,ew
+	write(2,874)ew
+	card='LINE'
+	write(1,9) card,ew,wlobs,star
+9	format(a4,f10.2,f10.4,1x,a56)
+	type 3227
+3227	format(3x,'code   ',$)
+	accept*,code1
+	if(wlobs.lt.100)unit=10
+	if(wlobs.ge.100.and.wlobs.lt.150.)unit=11
+	if(wlobs.ge.150.and.wlobs.lt.200.)unit=12
+	if(wlobs.ge.200.and.wlobs.lt.300.)unit=13
+	if(wlobs.ge.300.and.wlobs.lt.400.)unit=14
+	if(wlobs.ge.400.and.wlobs.lt.500.)unit=15
+	if(wlobs.ge.500.and.wlobs.lt.600.)unit=16
+	if(wlobs.ge.600.and.wlobs.lt.800.)unit=17
+	if(wlobs.ge.800.)unit=18
+	do 900 iline=1,50000000
+	read(unit,140,end=500)wl,gflog,code,e,xj,label,ep,xjp,labelp,
+	1 gammar,gammas,gammaw,ref,nblo,nbup,iso1,x1,iso2,x2,other1,
+	2 other2,lande,landeg,isoshift,alpha
+ 140	format(f11.4,f7.3,f6.2,f12.3,f5.1,1x,a10,f12.3,f5.1,1x,a10,
+	1 f6.2,f6.2,f6.2,a4,i2,i2,i3,f6.3,i3,f6.3,a10,a10,2i5,i6,f6.3)
+c
+	if(abs(wl-wlobs).le.0.002.and.code.eq.code1)then
+	write(1,444) wl,gflog,xj,e,xjp,ep,code,label,labelp
+444	format(f10.4,f7.3,f5.1,f12.3,f5.1,f12.3,f9.2,a10,a10)
+	nelem=code
+	icharge=(code-float(nelem))*100+0.1
+	zeff=icharge+1
+	nelion=nelem*6-6+ifix(zeff)
+	write(1,445)wl,nelion,gammar,gammas,gammaw,ref,nblo,nbup,iso1,
+	1 x1,iso2,x2,other1,other2,alpha
+445	format(f10.4,i4,f6.2,f6.2,f6.2,a4,i2,i2,i3,f7.3,i3,f7.3,
+	1 a10,a10,f6.3)
+	write(2,874)gflog
+	write(2,911)ref
+911	format(a4)
+	write(2,874)xj
+	write(2,8745)e
+	write(2,874)xjp
+	write(2,8745)ep
+	write(2,874)code
+9011	format(a10)
+	write(2,875)nelion
+875	format(1x,i5)
+	write(2,874)gammar
+	write(2,874) gammas
+	write(2,874)gammaw
+	write(2,873)alpha
+	rewind(unit)
+	go to 66
+	endif
+ 900	continue
+500	write(1,90) end
+83	type 503
+503	format(///,3x,'type the name of the model file ',$)
+	accept 90,modfile
+	open(unit=3,file=modfile,status='old')
+	do 993 i=1,500
+	read (3,90,end=999) c
+	write(modcard,'(a5)')c(1:5)
+c	type 342, modcard
+ 342	format(1x,a5)
+	if (modcard.ne.begin)write (1,90)c
+993	continue
+ 999	close (unit=3)
+	write(1,90)mol1
+	write(1,90)mol2
+	write(1,90)hlin
+        write(1,90)begin
+60	write(1,90)end
+	write(1,90)stop
+	close(unit=1)
+	stop
+	end