Update chatgpt_tuerme.f95

Uebung/SoSe2023/chatgpt_tuerme.f95

+MODULE  STACKMOD
+
+    IMPLICIT NONE
+  
+    PRIVATE
+   ! export list for module STACKMOD:                                 !
+    PUBLIC :: STACK, INIT, EMPTY, PUSH, POP, WRITE, DELETE,disc,top     
+    type disc
+        integer::num,color,diam
+    end type disc
+    TYPE  STACK
+      integer::top_pos
+      TYPE(STACKELEM), POINTER :: TOP
+    END TYPE  STACK
+   
+    TYPE, PRIVATE :: STACKELEM      
+      type(disc)              :: DATA
+      TYPE(STACKELEM), POINTER :: SUCC
+    END TYPE  STACKELEM
+  
+   CONTAINS
+  
+   ! initializes stack to a defined state (empty) !
+    SUBROUTINE  INIT (S)
+      TYPE(STACK), INTENT(OUT) :: S
+      s%top_pos=0
+      NULLIFY (S%TOP)
+    END SUBROUTINE  INIT
+  
+   ! tests if stack is currently empty !
+    FUNCTION  EMPTY (S)
+      TYPE(STACK), INTENT(IN) :: S
+      LOGICAL                 :: EMPTY 
+      EMPTY =  .NOT. ASSOCIATED(S%TOP)
+    END FUNCTION  EMPTY 
+  
+   ! adds new top element to stack !
+    SUBROUTINE  PUSH (S, ELEM)
+      TYPE(STACK), INTENT(INOUT) :: S
+      type(disc), INTENT(IN)  :: ELEM
+      TYPE(STACKELEM), POINTER   :: PTR
+      INTEGER                    :: err_code
+      ALLOCATE (PTR, STAT = err_code)
+      IF ( err_code == 0 ) THEN
+        PTR%DATA = ELEM
+        PTR%SUCC => S%TOP
+        S%TOP => PTR
+        S%Top_pos=s%top_pos+1
+      ELSE
+        WRITE(*,*) ' Allocation failed, probably out of memory!'
+      END IF
+    END SUBROUTINE  PUSH 
+  
+   ! removes top element from stack and returns its CONTENT !            ! 4 !
+   ! via the second argument ELEM, if PRESENT               !
+    SUBROUTINE  POP (S, ELEM)
+      TYPE(STACK), INTENT(INOUT)           :: S
+      type(disc), INTENT(OUT), OPTIONAL :: ELEM
+      TYPE(STACKELEM), POINTER             :: PTR
+      INTEGER                              :: err_code
+      IF ( .NOT. EMPTY(S) ) THEN
+        PTR => S%TOP
+        IF ( PRESENT(ELEM) )  ELEM = PTR%DATA
+        S%TOP => PTR%SUCC
+        DEALLOCATE (PTR, STAT = err_code)
+
+        IF ( err_code /= 0 )then                                     
+         WRITE(*,*) ' Deallocation failed, inconsistent memory!'
+        else
+            S%top_pos=S%top_pos-1
+        end if
+      ELSE
+        WRITE(*,*) ' Cannot pop from empty stack!'
+      END IF
+    END SUBROUTINE  POP 
+
+   ! returns CONTENT of top element !
+    FUNCTION  TOP (S)
+        TYPE(STACK), INTENT(IN) :: S
+        type(disc)           :: TOP
+        IF ( .NOT. EMPTY(S) ) THEN
+          TOP = S%TOP%DATA
+        ELSE                !!! Output in a function can be a PROBLEM !!!
+          WRITE(*,*) ' Cannot get top of empty stack!'
+        END IF
+      END FUNCTION  TOP
+   ! writes complete stack from top to bottom       !                    ! 5 !
+   ! (low level - should be inside module STACKMOD) !
+    SUBROUTINE  WRITE (S)
+      TYPE(STACK), INTENT(IN)  :: S
+      TYPE(STACKELEM), POINTER :: PTR
+      PTR => S%TOP
+      DO WHILE ( ASSOCIATED(PTR) )
+        write(*,*)PTR%DATA%num
+        PTR => PTR%SUCC
+      END DO
+      WRITE(*,*)
+    END SUBROUTINE  WRITE
+  
+    SUBROUTINE  DELETE (S)
+      TYPE(STACK), INTENT(INOUT) :: S
+      TYPE(STACKELEM), POINTER   :: PTR
+      INTEGER                    :: err_code
+      DO WHILE ( ASSOCIATED(S%TOP) )
+        PTR => S%TOP
+        S%TOP => PTR%SUCC
+        DEALLOCATE (PTR, STAT = err_code)
+        IF ( err_code /= 0 ) THEN
+          WRITE(*,*) ' Deallocation failed, inconsistent memory!'
+          EXIT   ! >----------------------------------->>> EXIT !
+        END IF
+      END DO
+    END SUBROUTINE  DELETE
+  
+  
+  
+  END MODULE  STACKMOD
+
 PROGRAM TowersOfHanoi
     USE STACKMOD
     IMPLICIT NONE