PR2

Heart_Under_Blade

Mar 8th, 2022

1,677

Never

Add comment

Not a member of Pastebin yet? Sign Up, it unlocks many cool features!

Fortran 6.55 KB | None | 0 0

raw download clone embed print report

program main
implicit none
call input
call table
print *, 'The program has completed successfully'
stop
end
subroutine input
implicit none
integer 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
open(111,FILE='input.txt', status='old', IOSTAT=IERR, err=404)
read (111,*) X_min,X_max,dx,Y_min,Y_max,dy
close(111)
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,temp_sin,temp_cos,eps_null
integer error_code
character*3 error_str
error_code = 0
error_str = ' '
temp_sin = sin(value)
if(temp_sin .EQ. 0) then
error_code = 1 !divided by zero
error_str = 'NaN'
return
elseif(abs(temp_sin) .LE. eps_null) then
error_code = -1 !infinity
error_str = 'INF'
return
endif
temp_cos = cos(value)
if(abs(temp_cos) .LE. eps_null) then
temp_cos = 0
endif
result = temp_cos/temp_sin
end
subroutine find_steps(array,min,max,dx,n,eps,eps_null)
implicit none
character*15 str1,str2,str3
integer i,n
real array(*),eps,temp,min,max,dx,eps_null
real epsilon_power, power_temp
n = 5
temp = min
do 10 i=1,n
!Check max, eps = 10**(-3 + [lg|dx|])
if(temp .GE. max .OR. abs(temp-max) .LE. eps) then
n = i
array(n) = max
return
endif
!End check max
if(abs(temp) .LE. eps_null) temp = 0
array(i) = temp
!Skip invisible steps
write (str3,'(E13.7)') temp
write (str1,'(A6)') str3
write (str2,'(A6)') str3
20 if(str1 .EQ. str2) then
temp = temp + dx
write (str3,'(E13.7)') temp
write (str1,'(A6)') str3
goto 20
endif
!End skip invisible steps
power_temp = epsilon_power(temp,dx,eps)
temp = anint(temp*10**(-power_temp))*10**power_temp
if(abs(temp) .LE. eps_null) temp = 0
10 continue
min = temp
return
end
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 table
implicit none
integer IERR,error_code,n,m,i,j
real array_x(5), array_y(5)
character*3 error_string
real X_min,X_max,dx,Y_min,Y_max,dY,degreeToRadian,result
real eps_dx, eps_dy, temp, eps_null
common /arguments/ X_min,X_max,dx,Y_min,Y_max,dY
common /const/ degreeToRadian
degreeToRadian=3.1415926/180
open(112,FILE='output.txt',status='unknown',IOSTAT=IERR,err=404)
eps_null = 1e-10
eps_dx = 10**aint(log10(abs(dx)) - 3)
eps_dy = 10**aint(log10(abs(dy)) - 3)
if(eps_null .GE. eps_dx) then
eps_null = eps_dx*degreeToRadian
elseif(eps_null .GE. eps_dy) then
eps_null = eps_dy*degreeToRadian
endif
10 continue
call find_steps(array_x,X_min,X_max,dx,n,eps_dx,eps_null)
temp = Y_min
20 continue
m = 5
call find_steps(array_y,temp,Y_max,dy,m,eps_dy,eps_null)
do i = 1, n + 1
write(112,1000) !print ---
enddo
write(112,1020)
write(112,1030) 'y/x'
write(112,1010) (array_x(i), i=1,n)
write(112,1020)
do i = 1, n + 1
write(112,1000) !print ---
enddo
write(112,1020)
do 100 i = 1,m
write(112,1010) array_y(i)
do 110 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(112,1010) result
else
write(112,1030) error_string
endif
110 continue
write(112,1020)
100 continue
do i = 1, n + 1
write(112,1000) !print ---
enddo
write(112,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(112)
return
c Formats
1000 format(15('-')\)
1010 format('| 'E11.4\' |')
1020 format(/\)
1030 format('| 'A\' |')
c Output file errors
404 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

Add Comment

Please, Sign In to add comment