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