Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- program main
- implicit none
- call input
- call table
- print *, 'The program has completed successfully'
- stop
- end
- subroutine input
- implicit none
- integer ui, IERR
- real X_min,X_max,dx,Y_min,Y_max,dy
- real temp_x, temp_y
- common /arguments/ X_min,X_max,dx,Y_min,Y_max,dy
- parameter(ui=111)
- open(ui,FILE='input.txt', status='old', IOSTAT=IERR, err=404)
- read (ui,*) X_min,X_max,dx,Y_min,Y_max,dy
- close(ui)
- c Checking input values
- if(dx .LE. 0 .OR. dy .LE. 0) then
- write(6,*) 'Input values error: Wrong x/y step'
- stop
- elseif(X_min .GT. X_max .OR. Y_min .GT. Y_max) then
- write(6,*) 'Input values error: Wrong min/max arguments'
- stop
- endif
- !Checking if step is too low
- !Example: x: 0.01; step: 0.000000001; - error
- temp_x = X_min + dx
- temp_y = Y_min + dy
- if(temp_x .EQ. X_min .OR. temp_y .EQ. Y_min) then
- write(6,*) 'Input values error: x/y step is too low'
- stop
- endif
- return
- c Input error
- 404 if(IERR .EQ. 29) then !FOR$IOS_FILNOTFOU
- write(6,*) 'Error: File does not exist'
- elseif(IERR .EQ. 43) then !FOR$IOS_FILNAMSPE
- write(6,*) 'Error: File name specification error'
- elseif(IERR .EQ. 9) then !FOR$IOS_PERACCFIL
- write(6,*) 'Error: Permission to access file denied'
- else
- write(6,*) 'Error: Undefined error, code = ', IERR
- endif
- print *, 'Input file error', IERR
- stop
- end
- subroutine cotg(value,eps_null,result,error_code,error_str)
- implicit none
- real result, value, eps_null
- real temp
- integer error_code
- character*3 error_str
- error_code = 0
- error_str = ' '
- temp = sin(value)
- if(temp .EQ. 0) then
- error_code = 1 !divided by zero
- error_str = 'NaN'
- return
- elseif(abs(temp) .LE. eps_null) then
- error_code = -1 !infinity
- error_str = 'INF'
- return
- endif
- result = cos(value)/temp
- end
- !proverit sverhu ili snizy razmeshenie functions
- !0.00001 = a
- !0.0001 = da
- !log10(0.00009)
- real function epsilon_power(a,da,epsilon_da)
- implicit none
- real a, da, epsilon_da
- if(abs(a) .LT. 1) then
- if(abs(a) .GT. epsilon_da) then
- epsilon_power = aint(log10(abs(a))) - 4
- else
- epsilon_power = aint(log10(abs(a-da))) - 4
- endif
- else
- epsilon_power = aint(log10(abs(a))) - 3
- endif
- end
- subroutine find_steps(array,min,max,dx,n,eps)
- implicit none
- integer n
- real array(*)
- real epsilon_power
- real temp,privious,min,max,dx
- real power_temp, eps
- n = 0
- temp = min
- !! 20 eto N dlya array
- 10 if(n .LT. 20) then
- n = n + 1
- !Check max
- if(temp .GE. max .OR. abs(temp-max) .LE. eps) then
- array(n) = max
- return
- endif
- !End check max
- if(abs(temp) .LT. eps) temp = 0
- array(n) = temp
- power_temp = epsilon_power(temp,dx,eps)
- privious = anint(temp*10**(-power_temp))*10**power_temp
- temp = temp + dx
- !Skip invisible steps
- 20 power_temp = epsilon_power(temp,dx,eps)
- if(abs(temp-privious) .LT. 0.9*10**power_temp) then
- temp = temp + dx
- goto 20
- endif
- !End skip invisible steps
- temp = anint(temp*10**(-power_temp))*10**power_temp
- goto 10
- endif
- min = temp
- return
- end
- subroutine table
- implicit none
- integer uo, IERR, error_code
- integer n,m,i,j
- real array_x(20), array_y(20)
- character*3 error_string
- real X_min,X_max,dx,Y_min,Y_max,dY
- real degreeToRadian, result
- real eps_null, eps_dx, eps_dy
- real temp
- common /arguments/ X_min,X_max,dx,Y_min,Y_max,dY
- common /const/ degreeToRadian
- parameter(uo=112)
- degreeToRadian = 3.1415926/180
- !!!!!!!!!!!!!!!!!!!!!!!
- ! TASK: CHECK ERR=404
- !!!!!!!!!!!1
- open(uo,FILE='output.txt',status='unknown',IOSTAT=IERR,err=405)
- eps_dx = 10**aint(log10(abs(dx)) - 3)
- eps_dy = 10**aint(log10(abs(dy)) - 3)
- if(eps_dx .LT. eps_dy) then
- eps_null = 10*eps_dx*degreeToRadian !!!!!! 10 DELETE
- else
- eps_null = 10*eps_dy*degreeToRadian
- endif
- !x do while
- 10 continue
- call find_steps(array_x,X_min,X_max,dx,n,eps_dx)
- temp = Y_min
- !y do while
- 20 continue
- call find_steps(array_y,temp,Y_max,dy,m,eps_dy)
- do i = 1, n + 1
- write(uo,1000) !print ---
- enddo
- write(uo,1020)
- write(uo,1030) 'y/x'
- write(uo,1010) (array_x(i), i=1,n)
- write(uo,1020)
- do i = 1, n + 1
- write(uo,1000) !print ---
- enddo
- write(uo,1020)
- do i = 1,m
- write(uo,1010) array_y(i)
- do j = 1,n
- call cotg((array_y(i)+array_x(j))*degreeToRadian,
- * eps_null, result, error_code, error_string)
- if(error_code .EQ. 0) then
- write(uo,1010) result
- else
- write(uo,1030) error_string
- endif
- enddo
- write(uo,1020)
- enddo
- do i = 1, n + 1
- write(uo,1000) !print ---
- enddo
- write(uo,1020)
- if(array_y(m) .NE. Y_max) goto 20 !end do while
- if(array_x(n) .NE. X_max) goto 10 !end do while
- close(uo)
- return
- c Formats
- 1000 format(15('-')\)
- 1010 format('| 'E11.4\' |')
- 1020 format(/\)
- 1030 format('| 'A\' |')
- c Output file errors
- 405 if(IERR .EQ. 43) then !FOR$IOS_FILNAMSPE
- write(6,*) 'Output error: File specification error'
- elseif(IERR .EQ. 10) then !FOR$IOS_CANOVEEXI
- write(6,*) 'Output error: Cannot overwrite existing file'
- elseif(IERR .EQ. 21) then !FOR$IOS_DUPFILSPE
- write(6,*) 'Output error: Duplicate file specifications'
- else
- write(6,*) 'Output error: Undefined error, code = ', IERR
- endif
- print *, 'Output file error ', IERR
- stop
- end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement