180 lines
4.8 KiB
Fortran
180 lines
4.8 KiB
Fortran
SUBROUTINE FIT_OUT
|
|
C ------------------
|
|
include 'fit.inc'
|
|
C
|
|
CHARACTER ANSW, FILNAM1*128
|
|
INTEGER FILENG,FILN1,i1,isys,iostat,l
|
|
CHARACTER FILNOUT*(MAXfLEN)
|
|
DATA FILNOUT/' '/
|
|
C
|
|
C- Create output file
|
|
C- Full name can be given. If extension is missed, default .FIT is used.
|
|
IF (FILNOUT .NE.' ') THEN ! not first call
|
|
10 WRITE (ISYSWR,1010)
|
|
READ (ISYSRD,'(A)',ERR=10,END=99) ANSW
|
|
IF ((ANSW.NE.'Y').AND.(ANSW.NE.'y')) THEN
|
|
call sys_open(2,FILNOUT,'a',iostat)
|
|
if (iostat .ne. 0) goto 41
|
|
GOTO 50
|
|
ENDIF
|
|
ENDIF
|
|
20 WRITE (ISYSWR,1011)
|
|
READ (ISYSRD,'(A)',END=91,err=91) FILNOUT
|
|
call str_trim(FILNOUT, FILNOUT, FILENG)
|
|
if (FILNOUT(1:FILENG) .EQ. ' ') goto 99
|
|
FILN1 = INDEX(FILNOUT,'.')
|
|
IF (FILN1.EQ.0) THEN
|
|
FILNOUT = FILNOUT(1:FILENG) // '.FIT'
|
|
ENDIF
|
|
C
|
|
40 call sys_open(2,FILNOUT,'w',iostat)
|
|
41 if (iostat .ne. 0) then
|
|
call str_trim(filnout,filnout,l)
|
|
print *,'cannot open ',FILNOUT(1:l)
|
|
goto 91
|
|
endif
|
|
C
|
|
50 INQUIRE (2,NAME=FILNAM1) ! Determine full file name
|
|
I1 = INDEX(FILNAM1,']') +1 ! Strip off directory description
|
|
FILNAM1 = FILNAM1(I1:)
|
|
ISYS=ISYSWR
|
|
ISYSWR=2
|
|
WRITE (ISYSWR,1009,ERR=90) ITIT, filnam(1:80)
|
|
CALL FIT_PRINT(1)
|
|
WRITE (ISYS,1012) FILNAM1(1:80)
|
|
70 WRITE (ISYS,1013)
|
|
READ (ISYSRD,'(A)',ERR=70,END=90) ANSW
|
|
IF ((ANSW.EQ.'Y').OR.(ANSW.EQ.'y')) CALL fit_LIST
|
|
90 CLOSE(2)
|
|
ISYSWR=ISYS
|
|
99 RETURN
|
|
91 FILNOUT=' '
|
|
RETURN
|
|
C
|
|
1009 FORMAT (//1X,78(1H*)/1X,A/1X,78(1H*)/1X,A)
|
|
1010 FORMAT (/,4X,'Create NEW output file (Y/N) : ',$)
|
|
1011 FORMAT (/,4X,'Name for output file: ',$)
|
|
1012 FORMAT (/,4X,'Parameter-List stored in file ',A)
|
|
1013 FORMAT (/,4X,'Store also X,Y,YFIT,CHI**2 (Y/N) ? ',$)
|
|
END
|
|
|
|
|
|
subroutine fit_write(filearg)
|
|
! filearg = ' ': write parameters listed in command line ('WRITE' or 'K' command)
|
|
! filearg != ' ': open file for keeping parameters ('OPEN' command)
|
|
|
|
include 'fit.inc'
|
|
|
|
character filearg*(*)
|
|
character*512 file, head, lasthead, lastfile, line, lastcmd
|
|
character*11 nam
|
|
integer iarg, p, l, ll, lh, lun, i
|
|
integer iostat
|
|
real value
|
|
data file/'fit.txt'/
|
|
data lastfile/' '/
|
|
data lasthead/' '/
|
|
data lastcmd/'k'/
|
|
|
|
if (filearg .ne. ' ') then
|
|
file = filearg
|
|
call sys_delete_file(filearg)
|
|
return
|
|
endif
|
|
|
|
call arg_par_sym_num(iarg, p, l)
|
|
if (iarg .eq. 0) then
|
|
if (lastcmd .eq. 'k') then
|
|
do iarg=1,min(nu,512/9)
|
|
if (psho(iarg) .ne. ' ') then
|
|
lastcmd(iarg*9+1:iarg*9+8) = psho(iarg)
|
|
else
|
|
lastcmd(iarg*9+1:iarg*9+8) = pnam(iarg)
|
|
endif
|
|
enddo
|
|
endif
|
|
call str_trim(cmdline, lastcmd, linlen)
|
|
cmdpos = 0
|
|
call arg_gen(iarg, cmdlen)
|
|
call arg_par_sym_num(iarg, p, l)
|
|
else
|
|
lastcmd = cmdline
|
|
endif
|
|
|
|
ll=0
|
|
lh=0
|
|
do while (iarg .ne. 0 .and. lh+24 .le. len(line) .and.
|
|
1 ll+24 .le. len(line))
|
|
if (iarg .eq. -1) then ! was a variable name
|
|
value = none
|
|
call fit_get_real(cmdline(p+1:p+l), value)
|
|
call str_trim(nam, cmdline(p+1:p+l), l)
|
|
if (l .le. 8) l=8
|
|
head(lh+1:lh+l)=nam
|
|
lh=lh+l+1
|
|
head(lh:lh)=char(9) ! tab
|
|
if (value .eq. none) then
|
|
line(ll+1:ll+1)=' '
|
|
ll=ll+2
|
|
else
|
|
call cvt_real_str(line(ll+1:ll+11), i, value, 8,0,6,3)
|
|
if (i .lt. 8) i=8
|
|
ll=ll+i+1
|
|
endif
|
|
line(ll:ll)=char(9) ! tab
|
|
else
|
|
if (iarg .eq. -2) then ! was parameter number
|
|
iarg = p
|
|
if (psho(iarg) .ne. ' ') then
|
|
nam(1:8) = psho(iarg)
|
|
else
|
|
nam(1:8) = pnam(iarg)
|
|
endif
|
|
else ! parameter name
|
|
call str_trim(nam(1:8), cmdline(p+1:p+l), l)
|
|
endif
|
|
if (iarg .gt. 0 .and. iarg .le. nu + max(0,ni)) then
|
|
head(lh+1:lh+8)=nam(1:8)
|
|
lh=lh+9
|
|
head(lh:lh)=char(9) ! tab
|
|
call cvt_real_str(line(ll+1:ll+11), i, u(iarg), 8,0,6,3)
|
|
if (i .lt. 8) i=8
|
|
ll=ll+i+1
|
|
line(ll:ll)=char(9) ! tab
|
|
head(lh+1:lh+3)='sig'
|
|
call str_trim(head(lh+4:lh+11), nam(1:8), l)
|
|
l=l+3
|
|
if (l .lt. 8) l=8
|
|
lh=lh+l+1
|
|
head(lh:lh)=char(9) ! tab
|
|
call cvt_real_str(line(ll+1:ll+11), i, werr(iarg),8,0,6,3)
|
|
if (i .lt. 8) i=8
|
|
ll=ll+i+1
|
|
line(ll:ll)=char(9) ! tab
|
|
endif
|
|
endif
|
|
call arg_par_sym_num(iarg, p, l)
|
|
enddo
|
|
if (ll .gt. 0) then
|
|
call sys_get_lun(lun)
|
|
call sys_open(lun, file, 'a', iostat)
|
|
if (file .ne. lastfile) then
|
|
call str_trim(file, file, i)
|
|
print *,'write data to ',file(1:i)
|
|
print *,'- use command "OPEN filename" to use an other filename'
|
|
print *,'- use command "K par1,par2,..." to choose parameters'
|
|
write(lun, '(a)') head(1:lh)
|
|
lastfile = file
|
|
lasthead = head(1:lh)
|
|
else if (head(1:lh) .ne. lasthead) then
|
|
write(lun, '(a)') head(1:lh)
|
|
lasthead = head(1:lh)
|
|
endif
|
|
write(lun, '(a)') line(1:ll)
|
|
close(lun)
|
|
print *,head(1:lh)
|
|
print *,line(1:ll)
|
|
call sys_free_lun(lun)
|
|
endif
|
|
end
|