Advertisement
Heart_Under_Blade

main

Mar 1st, 2022
1,152
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1.       program main
  2.       implicit none
  3.       call input
  4.       call table
  5.       print *, 'The program has completed successfully'
  6.       stop
  7.       end
  8.  
  9.  
  10.       subroutine input
  11.       implicit none
  12.       integer ui, IERR
  13.       real X_min,X_max,dx,Y_min,Y_max,dy
  14.       real temp_x, temp_y
  15.       common /arguments/ X_min,X_max,dx,Y_min,Y_max,dy
  16.       parameter(ui=111)
  17.       open(ui,FILE='input.txt', status='old', IOSTAT=IERR, err=404)
  18.       read (ui,*) X_min,X_max,dx,Y_min,Y_max,dy  
  19.       close(ui)
  20. c Checking input values
  21.       if(dx .LE. 0 .OR. dy .LE. 0) then
  22.           write(6,*) 'Input values error:  Wrong x/y step'
  23.           stop
  24.       elseif(X_min .GT. X_max .OR. Y_min .GT. Y_max) then
  25.           write(6,*) 'Input values error: Wrong min/max arguments'
  26.           stop
  27.       endif
  28.       !Checking if step is too low
  29.       !Example: x: 0.01; step: 0.000000001; - error
  30.       temp_x = X_min + dx
  31.       temp_y = Y_min + dy
  32.       if(temp_x .EQ. X_min .OR. temp_y .EQ. Y_min) then
  33.           write(6,*) 'Input values error: x/y step is too low'
  34.           stop
  35.       endif
  36.       return
  37. c Input error        
  38.   404 if(IERR .EQ. 29) then !FOR$IOS_FILNOTFOU
  39.           write(6,*) 'Error: File does not exist'
  40.       elseif(IERR .EQ. 43) then !FOR$IOS_FILNAMSPE
  41.           write(6,*) 'Error: File name specification error'
  42.       elseif(IERR .EQ. 9) then !FOR$IOS_PERACCFIL
  43.           write(6,*) 'Error: Permission to access file denied'
  44.       else
  45.           write(6,*) 'Error: Undefined error, code = ', IERR
  46.       endif
  47.       print *, 'Input file error', IERR
  48.       stop
  49.       end
  50.  
  51.  
  52.       subroutine cotg(value,eps_null,result,error_code,error_str)
  53.       implicit none
  54.       real result, value, eps_null
  55.       real temp
  56.       integer error_code
  57.       character*3 error_str
  58.       error_code = 0
  59.       error_str = ' '
  60.       temp = sin(value)
  61.       if(temp .EQ. 0) then
  62.           error_code = 1 !divided by zero
  63.           error_str = 'NaN'
  64.           return
  65.       elseif(abs(temp) .LE. eps_null) then
  66.           error_code = -1 !infinity
  67.           error_str = 'INF'
  68.           return
  69.       endif
  70.       result = cos(value)/temp
  71.       end
  72.  
  73.  
  74.       !proverit sverhu ili snizy razmeshenie functions
  75.       !0.00001 = a
  76.       !0.0001 = da
  77.       !log10(0.00009)
  78.       real function epsilon_power(a,da,epsilon_da)
  79.       implicit none
  80.       real a, da, epsilon_da
  81.       if(abs(a) .LT. 1) then
  82.           if(abs(a) .GT. epsilon_da) then
  83.               epsilon_power = aint(log10(abs(a))) - 4
  84.           else
  85.               epsilon_power = aint(log10(abs(a-da))) - 4
  86.           endif
  87.       else
  88.           epsilon_power = aint(log10(abs(a))) - 3
  89.       endif
  90.       end
  91.  
  92.  
  93.       subroutine find_steps(array,min,max,dx,n,eps)
  94.       implicit none
  95.       integer n
  96.       real array(*)
  97.       real epsilon_power
  98.       real temp,privious,min,max,dx
  99.       real power_temp, eps
  100.       n = 0
  101.       temp = min
  102.       !! 20 eto N dlya array
  103.    10 if(n .LT. 20) then
  104.           n = n + 1
  105.           !Check max
  106.           if(temp .GE. max .OR. abs(temp-max) .LE. eps) then
  107.               array(n) = max
  108.               return
  109.           endif
  110.           !End check max
  111.           if(abs(temp) .LT. eps) temp = 0
  112.           array(n) = temp
  113.           power_temp = epsilon_power(temp,dx,eps)
  114.           privious = anint(temp*10**(-power_temp))*10**power_temp
  115.           temp = temp + dx
  116.           !Skip invisible steps
  117.    20     power_temp = epsilon_power(temp,dx,eps)
  118.           if(abs(temp-privious) .LT. 0.9*10**power_temp) then
  119.               temp = temp + dx
  120.               goto 20
  121.           endif
  122.           !End skip invisible steps
  123.           temp = anint(temp*10**(-power_temp))*10**power_temp
  124.           goto 10
  125.       endif
  126.       min = temp
  127.       return
  128.       end
  129.  
  130.  
  131.       subroutine table
  132.       implicit none
  133.       integer uo, IERR, error_code
  134.       integer n,m,i,j
  135.       real array_x(20), array_y(20)
  136.       character*3 error_string
  137.       real X_min,X_max,dx,Y_min,Y_max,dY
  138.       real degreeToRadian, result
  139.       real eps_null, eps_dx, eps_dy
  140.       real temp
  141.       common /arguments/ X_min,X_max,dx,Y_min,Y_max,dY
  142.       common /const/ degreeToRadian
  143.       parameter(uo=112)
  144.       degreeToRadian = 3.1415926/180
  145.       !!!!!!!!!!!!!!!!!!!!!!!
  146.       ! TASK: CHECK ERR=404
  147.       !!!!!!!!!!!1
  148.       open(uo,FILE='output.txt',status='unknown',IOSTAT=IERR,err=405)
  149.       eps_dx = 10**aint(log10(abs(dx)) - 3)
  150.       eps_dy = 10**aint(log10(abs(dy)) - 3)
  151.       if(eps_dx .LT. eps_dy) then
  152.           eps_null = 10*eps_dx*degreeToRadian !!!!!! 10 DELETE
  153.       else
  154.           eps_null = 10*eps_dy*degreeToRadian
  155.       endif
  156.       !x do while
  157.    10 continue
  158.           call find_steps(array_x,X_min,X_max,dx,n,eps_dx)
  159.           temp = Y_min
  160.           !y do while
  161.    20     continue
  162.               call find_steps(array_y,temp,Y_max,dy,m,eps_dy)
  163.               do i = 1, n + 1
  164.                   write(uo,1000) !print ---
  165.               enddo
  166.               write(uo,1020)
  167.               write(uo,1030) 'y/x'
  168.               write(uo,1010) (array_x(i), i=1,n)
  169.               write(uo,1020)
  170.               do i = 1, n + 1
  171.                   write(uo,1000) !print ---
  172.               enddo
  173.               write(uo,1020)
  174.               do i = 1,m
  175.                   write(uo,1010) array_y(i)
  176.                   do j = 1,n
  177.                     call cotg((array_y(i)+array_x(j))*degreeToRadian,
  178.      *             eps_null, result, error_code, error_string)
  179.                     if(error_code .EQ. 0) then
  180.                         write(uo,1010) result
  181.                     else
  182.                         write(uo,1030) error_string
  183.                     endif
  184.                   enddo
  185.                   write(uo,1020)
  186.               enddo
  187.               do i = 1, n + 1
  188.                   write(uo,1000) !print ---
  189.               enddo
  190.               write(uo,1020)
  191.           if(array_y(m) .NE. Y_max) goto 20 !end do while
  192.       if(array_x(n) .NE. X_max) goto 10 !end do while
  193.       close(uo)
  194.       return
  195. c Formats
  196.  1000 format(15('-')\)
  197.  1010 format('| 'E11.4\' |')
  198.  1020 format(/\)
  199.  1030 format('|     'A\'     |')
  200. c Output file errors
  201.   405 if(IERR .EQ. 43) then !FOR$IOS_FILNAMSPE
  202.           write(6,*) 'Output error: File specification error'
  203.       elseif(IERR .EQ. 10) then !FOR$IOS_CANOVEEXI
  204.           write(6,*) 'Output error: Cannot overwrite existing file'
  205.       elseif(IERR .EQ. 21) then !FOR$IOS_DUPFILSPE
  206.           write(6,*) 'Output error: Duplicate file specifications'
  207.       else
  208.           write(6,*) 'Output error: Undefined error, code = ', IERR
  209.       endif
  210.       print *, 'Output file error ', IERR
  211.       stop
  212.       end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement