You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
408 lines
13 KiB
Fortran
408 lines
13 KiB
Fortran
5 years ago
|
SUBROUTINE CSET(TTMIN,TTMAX,isz)
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
SAVE
|
||
|
|
INTEGER ICK5
|
||
|
|
!
|
||
|
|
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||
|
|
!IPK APR94
|
||
|
|
COMMON /RECOD/ IRECD,TSPC
|
||
|
|
DIMENSION NKEY(99)
|
||
|
|
CHARACTER*80 ILIND
|
||
|
|
LOGICAL SWITCH
|
||
|
|
DATA ITIM,VDM /0,-1.E15/
|
||
|
|
!
|
||
|
|
call setd(24)
|
||
|
|
IF(ITIM .EQ. 0) THEN
|
||
|
|
OMAX=VDM
|
||
|
|
OMIN=VDM
|
||
|
|
ick5=0
|
||
|
|
DO 200 N=1,99
|
||
|
|
CONTUR(N)=VDM
|
||
|
|
200 CONTINUE
|
||
|
|
ITIM=ITIM+1
|
||
|
|
ELSE
|
||
|
|
ITIM=ITIM+1
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
!
|
||
|
|
13 continue
|
||
|
|
!
|
||
|
|
! isz = 0 means no choice for data
|
||
|
|
! = 1 means data selectd
|
||
|
|
!
|
||
|
|
IF(TTMAX .EQ. TTMIN) THEN
|
||
|
|
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,&
|
||
|
|
'There are no contours for this case MAX=MIN'//CHAR(13)//'The model will return ','CONTOUR ERROR')
|
||
|
|
5010 FORMAT(F5.2)
|
||
|
|
RETURN
|
||
|
|
!ipk apr94
|
||
|
|
ENDIF
|
||
|
|
IF(ICK5 .EQ. 1) GO TO 250
|
||
|
|
!
|
||
|
|
! get an estimate of contour values
|
||
|
|
!
|
||
|
|
AT=ALOG10(TTMAX-TTMIN)
|
||
|
|
IF(AT .LT. 0.) THEN
|
||
|
|
CINTER = 10. ** (IFIX(AT - .5) - 1)
|
||
|
|
ELSE
|
||
|
|
CINTER = 10. ** (IFIX(AT + .5) - 1)
|
||
|
|
ENDIF
|
||
|
|
! CINTER = 10. ** (IFIX(ALOG10(TTMAX-TTMIN) + .5) - 1)
|
||
|
|
235 FINTER = CINTER
|
||
|
|
! write(*,*) cinter,numv
|
||
|
|
IF(TTMIN .GT. 0.) THEN
|
||
|
|
CONTUR(1)=IFIX(TTMIN/CINTER)*CINTER+0.001*cinter
|
||
|
|
ELSE
|
||
|
|
CONTUR(1)=IFIX((TTMIN-CINTER)/CINTER)*CINTER+0.001*cinter
|
||
|
|
ENDIF
|
||
|
|
NUMV=1
|
||
|
|
DO 240 N=2,99
|
||
|
|
CONTUR(N)=CONTUR(N-1)+FINTER
|
||
|
|
IF(CONTUR(N) .GT. TTMAX) THEN
|
||
|
|
NUMV=N
|
||
|
|
GO TO 245
|
||
|
|
ENDIF
|
||
|
|
240 END DO
|
||
|
|
NUMV=99
|
||
|
|
245 IF(NUMV .GT. 16) THEN
|
||
|
|
CINTER=CINTER*2.
|
||
|
|
GO TO 235
|
||
|
|
ENDIF
|
||
|
|
DO 247 N=NUMV+1,99
|
||
|
|
CONTUR(N)=VDM
|
||
|
|
247 END DO
|
||
|
|
250 CONTINUE
|
||
|
|
!
|
||
|
|
! print options when no startup data available
|
||
|
|
!
|
||
|
|
if(isz .eq. 1) then
|
||
|
|
call conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5)
|
||
|
|
if(icsp .lt. 0) then
|
||
|
|
GO TO 405
|
||
|
|
elseif(icsp .eq. 0) then
|
||
|
|
go to 405
|
||
|
|
endif
|
||
|
|
|
||
|
|
|
||
|
|
IF(ABS(ICSP) .EQ. 1) THEN
|
||
|
|
icsp=0
|
||
|
|
!
|
||
|
|
! this is log spacing
|
||
|
|
!
|
||
|
|
IF(TTMAX .GT. 0.) THEN
|
||
|
|
ALMAX=ALOG10(TTMAX)
|
||
|
|
ELSE
|
||
|
|
call clscrn
|
||
|
|
call symbl (0.1,7.0,0.25, &
|
||
|
|
& 'Maximum contour value is negative',0.0,33)
|
||
|
|
call symbl (0.1,6.5,0.25, &
|
||
|
|
& 'Reconsider your choice',0.0,22)
|
||
|
|
GO TO 250
|
||
|
|
ENDIF
|
||
|
|
IF(TTMIN .GT. 0.) THEN
|
||
|
|
ALMIN=ALOG10(TTMIN)
|
||
|
|
!ipk oct94 add a switch
|
||
|
|
IMINSW=0
|
||
|
|
ELSE
|
||
|
|
call clscrn
|
||
|
|
call symbl (0.1,7.0,0.25, &
|
||
|
|
& 'Minimum contour value is negative',0.0,33)
|
||
|
|
call symbl (0.1,6.5,0.25, &
|
||
|
|
& 'Value set to 10**10 less than max value',0.0,39)
|
||
|
|
ALMIN=ALMAX-10.
|
||
|
|
!ipk oct 94 add a switch
|
||
|
|
IMINSW=1
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
ALMIN=ALMAX-4.
|
||
|
|
!
|
||
|
|
IF(ALMAX .GT. 0.) THEN
|
||
|
|
LMAX=ALMAX
|
||
|
|
ELSE
|
||
|
|
LMAX=ALMAX-1.
|
||
|
|
ENDIF
|
||
|
|
IF(ALMIN .GT. 0.) THEN
|
||
|
|
LMIN=ALMIN+1.
|
||
|
|
ELSE
|
||
|
|
LMIN=ALMIN
|
||
|
|
ENDIF
|
||
|
|
!ipk oct94 NUMV=LMAX-LMIN+1
|
||
|
|
NUMV=LMAX-LMIN+1+IMINSW
|
||
|
|
IF(NUMV .LT. 8) THEN
|
||
|
|
NUMV=NUMV*2
|
||
|
|
IDB=2
|
||
|
|
ELSE
|
||
|
|
IDB=1
|
||
|
|
ENDIF
|
||
|
|
!ipk oct94
|
||
|
|
IF(IMINSW .EQ. 1) THEN
|
||
|
|
CONTUR(1)=0.
|
||
|
|
CONTUR(2)=10.**LMIN
|
||
|
|
K=2
|
||
|
|
ELSE
|
||
|
|
CONTUR(1)=10.**LMIN
|
||
|
|
K=1
|
||
|
|
ENDIF
|
||
|
|
IPW=LMIN
|
||
|
|
DO 350 N=IMINSW+2,NUMV,IDB
|
||
|
|
IF(IDB .EQ. 2) THEN
|
||
|
|
K=K+1
|
||
|
|
CONTUR(K)=CONTUR(K-1)*3.
|
||
|
|
ENDIF
|
||
|
|
IPW=IPW+1
|
||
|
|
K=K+1
|
||
|
|
CONTUR(K)=10.**IPW
|
||
|
|
350 CONTINUE
|
||
|
|
numv=k
|
||
|
|
!
|
||
|
|
! this is for entry of chosen contours
|
||
|
|
!
|
||
|
|
ELSEIF(abs(ICSP) .EQ. 2) THEN
|
||
|
|
icsp=0
|
||
|
|
CALL SORT(CONTUR,NKEY,NUMV)
|
||
|
|
ELSEIF(abs(ICSP) .EQ. 3) THEN
|
||
|
|
icsp=0
|
||
|
|
cinter=omax-omin
|
||
|
|
if(cinter .gt. 0.) then
|
||
|
|
cinter=cinter/(numv-1)
|
||
|
|
else
|
||
|
|
cinter=1.0
|
||
|
|
endif
|
||
|
|
contur(1)=omin
|
||
|
|
do i=2,numv
|
||
|
|
contur(i)=contur(i-1)+cinter
|
||
|
|
enddo
|
||
|
|
ENDIF
|
||
|
|
GO TO 250
|
||
|
|
!ipk july 1995 add this line
|
||
|
|
405 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
call setd(2)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
subroutine conpanel(icsp,ttmin,ttmax,numv,contur,omax,omin,ick5)
|
||
|
|
|
||
|
|
use winteracter
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
save
|
||
|
|
|
||
|
|
include 'D.inc'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
integer :: icsp,numv,nlim,ict,ictx,ick1,ick2,ick3,ick4,ick5,ierr,idf,ipos,numvold
|
||
|
|
real :: ttmin,ttmax,contur(99),omax,omin,VDX
|
||
|
|
character*80 labmax,labmin,labnum,labcon(30),labomax,labomin
|
||
|
|
VDX=-1.E14
|
||
|
|
write(labmax,'(f10.3)') ttmax
|
||
|
|
write(labmin,'(f10.3)') ttmin
|
||
|
|
|
||
|
|
if(omax .lt. vdx) then
|
||
|
|
labomax=labmax
|
||
|
|
else
|
||
|
|
write(labomax,'(f10.3)') omax
|
||
|
|
endif
|
||
|
|
|
||
|
|
if(omin .lt. vdx) then
|
||
|
|
labomin=labmin
|
||
|
|
else
|
||
|
|
write(labomin,'(f10.3)') omin
|
||
|
|
endif
|
||
|
|
write(labnum,'(i10)') numv
|
||
|
|
nlim=numv
|
||
|
|
if(nlim .gt. 30) nlim=numv
|
||
|
|
do ict=1,nlim
|
||
|
|
write(labcon(ict),'(f10.3)') contur(ict)
|
||
|
|
enddo
|
||
|
|
if(numv .lt. 30) then
|
||
|
|
do ict=numv+1,30
|
||
|
|
labcon(ict)=' '
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
|
||
|
|
90 continue
|
||
|
|
numvold=numv
|
||
|
|
|
||
|
|
call wdialogload(IDD_DIALOG02)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutString(idf_string1,labmax)
|
||
|
|
CALL WDialogPutString(idf_string2,labmin)
|
||
|
|
CALL WDialogPutString(idf_string3,labomax)
|
||
|
|
CALL WDialogPutString(idf_string22,labomin)
|
||
|
|
CALL WDialogPutString(idf_string23,labnum)
|
||
|
|
|
||
|
|
ictx=0
|
||
|
|
do ict=idf_string4,idf_string4+18-1
|
||
|
|
ictx=ictx+1
|
||
|
|
CALL WDialogPutString(ict,labcon(ictx))
|
||
|
|
enddo
|
||
|
|
ictx=ictx+1
|
||
|
|
ICT=idf_string24
|
||
|
|
CALL WDialogPutString(ict,labcon(ictx))
|
||
|
|
|
||
|
|
DO ict=idf_string25,idf_string25+9
|
||
|
|
ictx=ictx+1
|
||
|
|
CALL WDialogPutString(ict,labcon(ictx))
|
||
|
|
enddo
|
||
|
|
ictx=ictx+1
|
||
|
|
ICT=idf_string35
|
||
|
|
CALL WDialogPutString(ict,labcon(ictx))
|
||
|
|
|
||
|
|
! call wdialogputcheckbox(idf_check1,0)
|
||
|
|
! call wdialogputcheckbox(idf_check2,0)
|
||
|
|
! call wdialogputcheckbox(idf_check3,0)
|
||
|
|
! call wdialogputcheckbox(idf_check4,0)
|
||
|
|
call wdialogputcheckbox(idf_check5,ick5)
|
||
|
|
! if(icsp .eq. 0) then
|
||
|
|
call wdialogputRadioButton(idf_check1)
|
||
|
|
! endif
|
||
|
|
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_DIALOG02)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
do
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
! call wdialoggetcheckbox(idf_check1,ick1)
|
||
|
|
! call wdialoggetcheckbox(idf_check2,ick2)
|
||
|
|
! call wdialoggetcheckbox(idf_check3,ick3)
|
||
|
|
! call wdialoggetcheckbox(idf_check4,ick4)
|
||
|
|
call wdialoggetcheckbox(idf_check5,ick5)
|
||
|
|
CALL WDialoggetString(idf_string1,labmax)
|
||
|
|
CALL WDialoggetString(idf_string2,labmin)
|
||
|
|
CALL WDialoggetString(idf_string3,labomax)
|
||
|
|
CALL WDialoggetString(idf_string22,labomin)
|
||
|
|
CALL WDialoggetString(idf_string23,labnum)
|
||
|
|
call wdialoggetradiobutton(idf_check1,ipos)
|
||
|
|
call IStringToInteger(labnum,numv)
|
||
|
|
write(90,*) 'numvold',numvold,numv,ipos
|
||
|
|
if(numvold .ne. numv .and. ipos .ne. 4) ipos=3
|
||
|
|
!C if(ick1 .eq. 1) then
|
||
|
|
!C icsp=0
|
||
|
|
!C else
|
||
|
|
icsp=0
|
||
|
|
if(ipos .eq. 2) then
|
||
|
|
icsp=1
|
||
|
|
elseif(ipos .eq. 3) then
|
||
|
|
icsp=3
|
||
|
|
write(90,'(a)') 'numv',labnum
|
||
|
|
call IStringToInteger(labnum,numv)
|
||
|
|
if(infoError(1) .gt. 0) then
|
||
|
|
call wdialogload(IDD_DIALOG04)
|
||
|
|
CALL WDialogSelect(IDD_DIALOG04)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
120 continue
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
go to 90
|
||
|
|
endif
|
||
|
|
go to 120
|
||
|
|
endif
|
||
|
|
call IStringToReal(labomax,omax)
|
||
|
|
if(infoError(1) .gt. 0) then
|
||
|
|
call wdialogload(IDD_DIALOG04)
|
||
|
|
CALL WDialogSelect(IDD_DIALOG04)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
130 continue
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
go to 90
|
||
|
|
endif
|
||
|
|
go to 130
|
||
|
|
endif
|
||
|
|
call IStringToReal(labomin,omin)
|
||
|
|
if(infoError(1) .gt. 0) then
|
||
|
|
call wdialogload(IDD_DIALOG04)
|
||
|
|
CALL WDialogSelect(IDD_DIALOG04)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
140 continue
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
go to 90
|
||
|
|
endif
|
||
|
|
go to 140
|
||
|
|
endif
|
||
|
|
elseif(ipos .eq. 4) then
|
||
|
|
icsp=2
|
||
|
|
write(90,'(a)') 'numv-4',labnum
|
||
|
|
! read(labnum,*) numv
|
||
|
|
call IStringToInteger(labnum,numv)
|
||
|
|
if(infoError(1) .gt. 0) then
|
||
|
|
call wdialogload(IDD_DIALOG04)
|
||
|
|
CALL WDialogSelect(IDD_DIALOG04)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
150 continue
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
go to 90
|
||
|
|
endif
|
||
|
|
go to 150
|
||
|
|
endif
|
||
|
|
write(90,*) numv
|
||
|
|
ictx=0
|
||
|
|
do ict=idf_string4,idf_string4+18-1
|
||
|
|
ictx=ictx+1
|
||
|
|
CALL WDialogGetString(ict,labcon(ictx))
|
||
|
|
enddo
|
||
|
|
ictx=ictx+1
|
||
|
|
ICT=idf_string24
|
||
|
|
CALL WDialogGetString(ict,labcon(ictx))
|
||
|
|
do ict=idf_string25,idf_string25+9
|
||
|
|
ictx=ictx+1
|
||
|
|
CALL WDialogGetString(ict,labcon(ictx))
|
||
|
|
enddo
|
||
|
|
ictx=ictx+1
|
||
|
|
ICT=idf_string35
|
||
|
|
CALL WDialogGetString(ict,labcon(ictx))
|
||
|
|
do ict=1,numv
|
||
|
|
! read(labcon(ict),*) contur(ict)
|
||
|
|
call IStringToReal(labcon(ict),contur(ict))
|
||
|
|
if(infoError(1) .gt. 0) then
|
||
|
|
call wdialogload(IDD_DIALOG04)
|
||
|
|
CALL WDialogSelect(IDD_DIALOG04)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
160 continue
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
go to 90
|
||
|
|
endif
|
||
|
|
go to 160
|
||
|
|
endif
|
||
|
|
write(90,*) 'con',ict,contur(ict)
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
|
||
|
|
if(ipos .eq. 5) then
|
||
|
|
icsp=-5
|
||
|
|
! abs(icsp)
|
||
|
|
endif
|
||
|
|
write(90,*) 'icsp',icsp,omax,omin,numv,ipos
|
||
|
|
! write(90,*) 'ick',ick1,ick2,ick3,ick4,ick5
|
||
|
|
return
|
||
|
|
|
||
|
|
endif
|
||
|
|
return
|
||
|
|
enddo
|
||
|
|
return
|
||
|
|
end
|